File Coverage

File:Dpkg/Arch.pm
Coverage:89.6%

linestmtbrancondsubpodtimecode
1# Copyright © 2006-2015 Guillem Jover <guillem@debian.org>
2#
3# This program is free software; you can redistribute it and/or modify
4# it under the terms of the GNU General Public License as published by
5# the Free Software Foundation; either version 2 of the License, or
6# (at your option) any later version.
7#
8# This program is distributed in the hope that it will be useful,
9# but WITHOUT ANY WARRANTY; without even the implied warranty of
10# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11# GNU General Public License for more details.
12#
13# You should have received a copy of the GNU General Public License
14# along with this program.  If not, see <https://www.gnu.org/licenses/>.
15
16=encoding utf8
17
18 - 31
=head1 NAME

Dpkg::Arch - handle architectures

=head1 DESCRIPTION

The Dpkg::Arch module provides functions to handle Debian architectures,
wildcards, and mapping from and to GNU triplets.

No symbols are exported by default. The :all tag can be used to import all
symbols. The :getters, :parsers, :mappers and :operators tags can be used
to import specific symbol subsets.

=cut
32
33package Dpkg::Arch 1.03;
34
35
282
282
282
282
719
199
4297
use strict;
36
282
282
282
282
396
193
7307
use warnings;
37
282
282
282
282
600
176
28991
use feature qw(state);
38
39our @EXPORT_OK = qw(
40    get_raw_build_arch
41    get_raw_host_arch
42    get_build_arch
43    get_host_arch
44    get_host_gnu_type
45    get_valid_arches
46    debarch_eq
47    debarch_is
48    debarch_is_wildcard
49    debarch_is_illegal
50    debarch_is_concerned
51    debarch_to_abiattrs
52    debarch_to_cpubits
53    debarch_to_gnutriplet
54    debarch_to_debtuple
55    debarch_to_multiarch
56    debarch_list_parse
57    debtuple_to_debarch
58    debtuple_to_gnutriplet
59    gnutriplet_to_debarch
60    gnutriplet_to_debtuple
61    gnutriplet_to_multiarch
62);
63our %EXPORT_TAGS = (
64    all => [ @EXPORT_OK ],
65    getters => [ qw(
66        get_raw_build_arch
67        get_raw_host_arch
68        get_build_arch
69        get_host_arch
70        get_host_gnu_type
71        get_valid_arches
72    ) ],
73    parsers => [ qw(
74        debarch_list_parse
75    ) ],
76    mappers => [ qw(
77        debarch_to_abiattrs
78        debarch_to_gnutriplet
79        debarch_to_debtuple
80        debarch_to_multiarch
81        debtuple_to_debarch
82        debtuple_to_gnutriplet
83        gnutriplet_to_debarch
84        gnutriplet_to_debtuple
85        gnutriplet_to_multiarch
86    ) ],
87    operators => [ qw(
88        debarch_eq
89        debarch_is
90        debarch_is_wildcard
91        debarch_is_illegal
92        debarch_is_concerned
93    ) ],
94);
95
96
97
282
282
282
282
796
282
6429
use Exporter qw(import);
98
282
282
282
282
626
1017
7493
use List::Util qw(any);
99
100
282
282
282
282
2085
67
1964
use Dpkg ();
101
282
282
282
282
2073
274
6353
use Dpkg::Gettext;
102
282
282
282
282
3032
118
8699
use Dpkg::ErrorHandling;
103
282
282
282
282
38568
282
13270
use Dpkg::BuildEnv;
104
105my (@cpu, @os);
106my (%cputable, %ostable);
107my (%cputable_re, %ostable_re);
108my (%cpubits, %cpuendian);
109my %abibits;
110
111my %debtuple_to_debarch;
112my %debarch_to_debtuple;
113
114 - 123
=head1 FUNCTIONS

=over 4

=item $arch = get_raw_build_arch()

Get the raw build Debian architecture, without taking into account variables
from the environment.

=cut
124
125sub get_raw_build_arch()
126{
127
39
39
1
37
    state $build_arch;
128
129
39
100
90
    return $build_arch if defined $build_arch;
130
131    # Note: We *always* require an installed dpkg when inferring the
132    # build architecture. The bootstrapping case is handled by
133    # dpkg-architecture itself, by avoiding computing the DEB_BUILD_
134    # variables when they are not requested.
135
136    ## no critic (TestingAndDebugging::ProhibitNoWarnings)
137
282
282
282
282
656
138
24854
    no warnings qw(exec);
138
9
32152
    $build_arch = qx(dpkg --print-architecture);
139
9
50
137
    syserr('dpkg --print-architecture failed') if $? >> 8;
140
141
9
25
    chomp $build_arch;
142
9
141
    return $build_arch;
143}
144
145 - 150
=item $arch = get_build_arch()

Get the build Debian architecture, using DEB_BUILD_ARCH from the environment
if available.

=cut
151
152sub get_build_arch()
153{
154
153
67
153
1
165
    return Dpkg::BuildEnv::get('DEB_BUILD_ARCH') || get_raw_build_arch();
155}
156
157{
158    my %cc_host_gnu_type;
159
160    sub get_host_gnu_type()
161    {
162
12
50
12
0
34
        my $CC = $ENV{CC} || 'gcc';
163
164
12
100
28
        return $cc_host_gnu_type{$CC} if defined $cc_host_gnu_type{$CC};
165
166        ## no critic (TestingAndDebugging::ProhibitNoWarnings)
167
282
282
282
282
655
119
464722
        no warnings qw(exec);
168
9
22964
        $cc_host_gnu_type{$CC} = qx($CC -dumpmachine);
169
9
100
139
        if ($? >> 8) {
170
3
11
            $cc_host_gnu_type{$CC} = '';
171        } else {
172
6
22
            chomp $cc_host_gnu_type{$CC};
173        }
174
175
9
111
        return $cc_host_gnu_type{$CC};
176    }
177
178    sub set_host_gnu_type
179    {
180
3
3
0
5
        my ($host_gnu_type) = @_;
181
3
50
8
        my $CC = $ENV{CC} || 'gcc';
182
183
3
5
        $cc_host_gnu_type{$CC} = $host_gnu_type;
184    }
185}
186
187 - 192
=item $arch = get_raw_host_arch()

Get the raw host Debian architecture, without taking into account variables
from the environment.

=cut
193
194sub get_raw_host_arch()
195{
196
3
3
1
2
    state $host_arch;
197
198
3
50
3
    return $host_arch if defined $host_arch;
199
200
3
4
    my $host_gnu_type = get_host_gnu_type();
201
202
3
50
11
    if ($host_gnu_type eq '') {
203
0
0
        warning(g_('cannot determine CC system type, falling back to ' .
204                   'default (native compilation)'));
205    } else {
206
3
13
        my (@host_archtuple) = gnutriplet_to_debtuple($host_gnu_type);
207
3
7
        $host_arch = debtuple_to_debarch(@host_archtuple);
208
209
3
50
3
        if (defined $host_arch) {
210
3
4
            $host_gnu_type = debtuple_to_gnutriplet(@host_archtuple);
211        } else {
212
0
0
            warning(g_('unknown CC system type %s, falling back to ' .
213                       'default (native compilation)'), $host_gnu_type);
214
0
0
            $host_gnu_type = '';
215        }
216
3
7
        set_host_gnu_type($host_gnu_type);
217    }
218
219
3
50
6
    if (!defined($host_arch)) {
220        # Switch to native compilation.
221
0
0
        $host_arch = get_raw_build_arch();
222    }
223
224
3
21
    return $host_arch;
225}
226
227 - 232
=item $arch = get_host_arch()

Get the host Debian architecture, using DEB_HOST_ARCH from the environment
if available.

=cut
233
234sub get_host_arch()
235{
236
363
33
363
1
723
    return Dpkg::BuildEnv::get('DEB_HOST_ARCH') || get_raw_host_arch();
237}
238
239 - 243
=item @arch_list = get_valid_arches()

Get an array with all currently known Debian architectures.

=cut
244
245sub get_valid_arches()
246{
247
3
3
1
3
    _load_cputable();
248
3
10
    _load_ostable();
249
250
3
6
    my @arches;
251
252
3
4
    foreach my $os (@os) {
253
69
75
        foreach my $cpu (@cpu) {
254
2346
2125
            my $arch = debtuple_to_debarch(split(/-/, $os, 3), $cpu);
255
2346
100
2494
            push @arches, $arch if defined($arch);
256        }
257    }
258
259
3
141
    return @arches;
260}
261
262my %table_loaded;
263sub _load_table
264{
265
418128
418128
319262
    my ($table, $loader) = @_;
266
267
418128
100
434126
    return if $table_loaded{$table};
268
269
75
68
    local $_;
270
75
170
    local $/ = "\n";
271
272
75
50
1476
    open my $table_fh, '<', "$Dpkg::DATADIR/$table"
273        or syserr(g_('cannot open %s'), $table);
274
75
685
    while (<$table_fh>) {
275
3471
2193
        $loader->($_);
276    }
277
75
291
    close $table_fh;
278
279
75
347
    $table_loaded{$table} = 1;
280}
281
282sub _load_cputable
283{
284    _load_table('cputable', sub {
285
1296
100
1296
1795
        if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) {
286
816
1077
            $cputable{$1} = $2;
287
816
712
            $cputable_re{$1} = $3;
288
816
701
            $cpubits{$1} = $4;
289
816
749
            $cpuendian{$1} = $5;
290
816
1350
            push @cpu, $1;
291        }
292
147029
147029
358874
    });
293}
294
295sub _load_ostable
296{
297    _load_table('ostable', sub {
298
246
100
246
275
        if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) {
299
138
156
            $ostable{$1} = $2;
300
138
109
            $ostable_re{$1} = $3;
301
138
165
            push @os, $1;
302        }
303
1275
1275
2395
    });
304}
305
306sub _load_abitable()
307{
308    _load_table('abitable', sub {
309
273
100
273
384
        if (m/^(?!\#)(\S+)\s+(\S+)/) {
310
42
130
            $abibits{$1} = $2;
311        }
312
124070
124070
156668
    });
313}
314
315sub _load_tupletable()
316{
317
145754
145754
141316
    _load_cputable();
318
319    _load_table('tupletable', sub {
320
1656
100
1656
2148
        if (m/^(?!\#)(\S+)\s+(\S+)/) {
321
1104
820
            my $debtuple = $1;
322
1104
773
            my $debarch = $2;
323
324
1104
100
961
            if ($debtuple =~ /<cpu>/) {
325
120
121
                foreach my $_cpu (@cpu) {
326
4080
4142
                    (my $dt = $debtuple) =~ s/<cpu>/$_cpu/;
327
4080
3807
                    (my $da = $debarch) =~ s/<cpu>/$_cpu/;
328
329                    next if exists $debarch_to_debtuple{$da}
330
4080
100
67
7512
                         or exists $debtuple_to_debarch{$dt};
331
332
3984
4122
                    $debarch_to_debtuple{$da} = $dt;
333
3984
5203
                    $debtuple_to_debarch{$dt} = $da;
334                }
335            } else {
336
984
1225
                $debarch_to_debtuple{$2} = $1;
337
984
1866
                $debtuple_to_debarch{$1} = $2;
338            }
339        }
340
145754
435969
    });
341}
342
343sub debtuple_to_gnutriplet(@)
344{
345
645
645
0
1240
    my ($abi, $libc, $os, $cpu) = @_;
346
347
645
1149
    _load_cputable();
348
645
2700
    _load_ostable();
349
350    return unless
351        defined $abi && defined $libc && defined $os && defined $cpu &&
352
645
50
14
9249
        exists $cputable{$cpu} && exists $ostable{"$abi-$libc-$os"};
353
645
2142
    return join('-', $cputable{$cpu}, $ostable{"$abi-$libc-$os"});
354}
355
356sub gnutriplet_to_debtuple($)
357{
358
630
630
0
764
    my $gnu = shift;
359
630
100
941
    return unless defined($gnu);
360
627
1589
    my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2);
361
627
50
33
1958
    return unless defined($gnu_cpu) && defined($gnu_os);
362
363
627
876
    _load_cputable();
364
627
1460
    _load_ostable();
365
366
627
1132
    my ($os, $cpu);
367
368
627
912
    foreach my $_cpu (@cpu) {
369
10299
100
72383
        if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) {
370
624
827
            $cpu = $_cpu;
371
624
821
            last;
372        }
373    }
374
375
627
872
    foreach my $_os (@os) {
376
7371
100
56625
        if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) {
377
624
629
            $os = $_os;
378
624
656
            last;
379        }
380    }
381
382
627
100
67
2655
    return if !defined($cpu) || !defined($os);
383
624
4199
    return (split(/-/, $os, 3), $cpu);
384}
385
386 - 390
=item $multiarch = gnutriplet_to_multiarch($gnutriplet)

Map a GNU triplet into a Debian multiarch triplet.

=cut
391
392sub gnutriplet_to_multiarch($)
393{
394
15
15
1
15
    my $gnu = shift;
395
15
29
    my ($cpu, $cdr) = split(/-/, $gnu, 2);
396
397
15
100
32
    if ($cpu =~ /^i[4567]86$/) {
398
3
21
        return "i386-$cdr";
399    } else {
400
12
24
        return $gnu;
401    }
402}
403
404 - 408
=item $multiarch = debarch_to_multiarch($arch)

Map a Debian architecture into a Debian multiarch triplet.

=cut
409
410sub debarch_to_multiarch($)
411{
412
15
15
1
16
    my $arch = shift;
413
414
15
14
    return gnutriplet_to_multiarch(debarch_to_gnutriplet($arch));
415}
416
417sub debtuple_to_debarch(@)
418{
419
2985
2985
0
3173
    my ($abi, $libc, $os, $cpu) = @_;
420
421
2985
2699
    _load_tupletable();
422
423
2985
100
100
33
17139
    if (!defined $abi || !defined $libc || !defined $os || !defined $cpu) {
424
9
19
        return;
425    } elsif (exists $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}) {
426
1245
3765
        return $debtuple_to_debarch{"$abi-$libc-$os-$cpu"};
427    } else {
428
1731
1372
        return;
429    }
430}
431
432sub debarch_to_debtuple($)
433{
434
142775
142775
0
91277
    my $arch = shift;
435
436
142775
100
125675
    return if not defined $arch;
437
438
142769
149310
    _load_tupletable();
439
440
142769
100
380810
    if ($arch =~ /^linux-([^-]*)/) {
441        # XXX: Might disappear in the future, not sure yet.
442
18
33
        $arch = $1;
443    }
444
445
142769
133215
    my $tuple = $debarch_to_debtuple{$arch};
446
447
142769
100
124577
    if (defined($tuple)) {
448
142718
163953
        my @tuple = split /-/, $tuple, 4;
449
142718
100
313629
        return @tuple if wantarray;
450        return {
451
9
40
            abi => $tuple[0],
452            libc => $tuple[1],
453            os => $tuple[2],
454            cpu => $tuple[3],
455        };
456    } else {
457
51
1538
        return;
458    }
459}
460
461 - 465
=item $gnutriplet = debarch_to_gnutriplet($arch)

Map a Debian architecture into a GNU triplet.

=cut
466
467sub debarch_to_gnutriplet($)
468{
469
24
24
1
19
    my $arch = shift;
470
471
24
18
    return debtuple_to_gnutriplet(debarch_to_debtuple($arch));
472}
473
474 - 478
=item $arch = gnutriplet_to_debarch($gnutriplet)

Map a GNU triplet into a Debian architecture.

=cut
479
480sub gnutriplet_to_debarch($)
481{
482
9
9
1
12
    my $gnu = shift;
483
484
9
13
    return debtuple_to_debarch(gnutriplet_to_debtuple($gnu));
485}
486
487sub debwildcard_to_debtuple($)
488{
489
20328
20328
0
15986
    my $arch = shift;
490
20328
22924
    my @tuple = split /-/, $arch, 4;
491
492
20328
32634
100
32634
46368
31839
    if (any { $_ eq 'any' } @tuple) {
493
19428
100
100
100
22320
        if (scalar @tuple == 4) {
494
12072
24451
            return @tuple;
495        } elsif (scalar @tuple == 3) {
496
5340
10552
            return ('any', @tuple);
497        } elsif (scalar @tuple == 2) {
498
2013
3430
            return ('any', 'any', @tuple);
499        } else {
500
3
6
            return ('any', 'any', 'any', 'any');
501        }
502    } else {
503
900
807
        return debarch_to_debtuple($arch);
504    }
505}
506
507sub debarch_to_abiattrs($)
508{
509
124073
124073
0
80859
    my $arch = shift;
510
124073
101503
    my ($abi, $libc, $os, $cpu) = debarch_to_debtuple($arch);
511
512
124073
100
107134
    if (defined($cpu)) {
513
124070
117941
        _load_abitable();
514
515
124070
67
405915
        return ($abibits{$abi} // $cpubits{$cpu}, $cpuendian{$cpu});
516    } else {
517
3
7
        return;
518    }
519}
520
521sub debarch_to_cpubits($)
522{
523
9
9
0
15
    my $arch = shift;
524
9
11
    my $cpu;
525
526
9
20
    ((undef) x 3, $cpu) = debarch_to_debtuple($arch);
527
528
9
100
21
    if (defined $cpu) {
529
6
28
        return $cpubits{$cpu};
530    } else {
531
3
6
        return;
532    }
533}
534
535 - 540
=item $bool = debarch_eq($arch_a, $arch_b)

Evaluate the equality of a Debian architecture, by comparing with another
Debian architecture. No wildcard matching is performed.

=cut
541
542sub debarch_eq($$)
543{
544
24
24
1
40
    my ($a, $b) = @_;
545
546
24
100
67
    return 1 if ($a eq $b);
547
548
18
27
    my @a = debarch_to_debtuple($a);
549
18
29
    my @b = debarch_to_debtuple($b);
550
551
18
100
100
99
    return 0 if scalar @a != 4 or scalar @b != 4;
552
553
6
67
83
    return $a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2] && $a[3] eq $b[3];
554}
555
556 - 561
=item $bool = debarch_is($arch, $arch_wildcard)

Evaluate the identity of a Debian architecture, by matching with an
architecture wildcard.

=cut
562
563sub debarch_is($$)
564{
565
17199
17199
1
20324
    my ($real, $alias) = @_;
566
567
17199
100
100
54417
    return 1 if ($alias eq $real or $alias eq 'any');
568
569
16362
20148
    my @real = debarch_to_debtuple($real);
570
16362
19387
    my @alias = debwildcard_to_debtuple($alias);
571
572
16362
100
100
51547
    return 0 if scalar @real != 4 or scalar @alias != 4;
573
574
16353
100
90
123651
    if (($alias[0] eq $real[0] || $alias[0] eq 'any') &&
575        ($alias[1] eq $real[1] || $alias[1] eq 'any') &&
576        ($alias[2] eq $real[2] || $alias[2] eq 'any') &&
577        ($alias[3] eq $real[3] || $alias[3] eq 'any')) {
578
15456
39937
        return 1;
579    }
580
581
897
1630
    return 0;
582}
583
584 - 588
=item $bool = debarch_is_wildcard($arch)

Evaluate whether a Debian architecture is an architecture wildcard.

=cut
589
590sub debarch_is_wildcard($)
591{
592
3969
3969
1
3735
    my $arch = shift;
593
594
3969
100
5237
    return 0 if $arch eq 'all';
595
596
3966
4500
    my @tuple = debwildcard_to_debtuple($arch);
597
598
3966
100
7666
    return 0 if scalar @tuple != 4;
599
3963
5805
100
5805
7790
11987
    return 1 if any { $_ eq 'any' } @tuple;
600
3
7
    return 0;
601}
602
603 - 610
=item $bool = debarch_is_illegal($arch, %options)

Validate an architecture name.

If the "positive" option is set to a true value, only positive architectures
will be accepted, otherwise negated architectures are allowed.

=cut
611
612sub debarch_is_illegal
613{
614
99
99
1
105
    my ($arch, %opts) = @_;
615
99
144
    my $arch_re = qr/[a-zA-Z0-9][a-zA-Z0-9-]*/;
616
617
99
100
123
    if ($opts{positive}) {
618
18
161
        return $arch !~ m/^$arch_re$/;
619    } else {
620
81
521
        return $arch !~ m/^!?$arch_re$/;
621    }
622}
623
624 - 629
=item $bool = debarch_is_concerned($arch, @arches)

Evaluate whether a Debian architecture applies to the list of architecture
restrictions, as usually found in dependencies inside square brackets.

=cut
630
631sub debarch_is_concerned
632{
633
525
525
1
924
    my ($host_arch, @arches) = @_;
634
635
525
475
    my $seen_arch = 0;
636
525
588
    foreach my $arch (@arches) {
637
1107
1030
        $arch = lc $arch;
638
639
1107
100
100
1916
        if ($arch =~ /^!/) {
640
663
554
            my $not_arch = $arch;
641
663
953
            $not_arch =~ s/^!//;
642
643
663
100
745
            if (debarch_is($host_arch, $not_arch)) {
644
132
121
                $seen_arch = 0;
645
132
184
                last;
646            } else {
647                # !arch includes by default all other arches
648                # unless they also appear in a !otherarch
649
531
646
                $seen_arch = 1;
650            }
651        } elsif (debarch_is($host_arch, $arch)) {
652
84
101
            $seen_arch = 1;
653
84
111
            last;
654        }
655    }
656
525
2369
    return $seen_arch;
657}
658
659 - 666
=item @array = debarch_list_parse($arch_list, %options)

Parse an architecture list.

If the "positive" option is set to a true value, only positive architectures
will be accepted, otherwise negated architectures are allowed.

=cut
667
668sub debarch_list_parse
669{
670
42
42
1
59
    my ($arch_list, %opts) = @_;
671
42
58
    my @arch_list = split ' ', $arch_list;
672
673
42
48
    foreach my $arch (@arch_list) {
674
72
100
73
        if (debarch_is_illegal($arch, %opts)) {
675
6
24
            error(g_("'%s' is not a legal architecture in list '%s'"),
676                  $arch, $arch_list);
677        }
678    }
679
680
36
67
    return @arch_list;
681}
682
6831;
684
685=back
686
687 - 708
=head1 CHANGES

=head2 Version 1.03 (dpkg 1.19.1)

New argument: Accept a "positive" option in debarch_is_illegal() and
debarch_list_parse().

=head2 Version 1.02 (dpkg 1.18.19)

New import tags: ":all", ":getters", ":parsers", ":mappers", ":operators".

=head2 Version 1.01 (dpkg 1.18.5)

New functions: debarch_is_illegal(), debarch_list_parse().

=head2 Version 1.00 (dpkg 1.18.2)

Mark the module as public.

=head1 SEE ALSO

L<dpkg-architecture(1)>.