File Coverage

File:Dpkg/Arch.pm
Coverage:89.1%

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
16package Dpkg::Arch;
17
18=encoding utf8
19
20 - 33
=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
34
35
65
65
65
65
133
52
660
use strict;
36
65
65
65
65
71
12
1126
use warnings;
37
65
65
65
65
80
51
5542
use feature qw(state);
38
39our $VERSION = '1.03';
40our @EXPORT_OK = qw(
41    get_raw_build_arch
42    get_raw_host_arch
43    get_build_arch
44    get_host_arch
45    get_host_gnu_type
46    get_valid_arches
47    debarch_eq
48    debarch_is
49    debarch_is_wildcard
50    debarch_is_illegal
51    debarch_is_concerned
52    debarch_to_abiattrs
53    debarch_to_cpubits
54    debarch_to_gnutriplet
55    debarch_to_debtuple
56    debarch_to_multiarch
57    debarch_list_parse
58    debtuple_to_debarch
59    debtuple_to_gnutriplet
60    gnutriplet_to_debarch
61    gnutriplet_to_debtuple
62    gnutriplet_to_multiarch
63);
64our %EXPORT_TAGS = (
65    all => [ @EXPORT_OK ],
66    getters => [ qw(
67        get_raw_build_arch
68        get_raw_host_arch
69        get_build_arch
70        get_host_arch
71        get_host_gnu_type
72        get_valid_arches
73    ) ],
74    parsers => [ qw(
75        debarch_list_parse
76    ) ],
77    mappers => [ qw(
78        debarch_to_abiattrs
79        debarch_to_gnutriplet
80        debarch_to_debtuple
81        debarch_to_multiarch
82        debtuple_to_debarch
83        debtuple_to_gnutriplet
84        gnutriplet_to_debarch
85        gnutriplet_to_debtuple
86        gnutriplet_to_multiarch
87    ) ],
88    operators => [ qw(
89        debarch_eq
90        debarch_is
91        debarch_is_wildcard
92        debarch_is_illegal
93        debarch_is_concerned
94    ) ],
95);
96
97
98
65
65
65
65
119
140
727
use Exporter qw(import);
99
65
65
65
65
83
76
1432
use List::Util qw(any);
100
101
65
65
65
65
485
13
436
use Dpkg ();
102
65
65
65
65
528
51
1166
use Dpkg::Gettext;
103
65
65
65
65
626
46
1572
use Dpkg::ErrorHandling;
104
65
65
65
65
7595
59
2329
use Dpkg::Build::Env;
105
106my (@cpu, @os);
107my (%cputable, %ostable);
108my (%cputable_re, %ostable_re);
109my (%cpubits, %cpuendian);
110my %abibits;
111
112my %debtuple_to_debarch;
113my %debarch_to_debtuple;
114
115 - 124
=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
125
126sub get_raw_build_arch()
127{
128
1
1
1
1
    state $build_arch;
129
130
1
50
1
    return $build_arch if defined $build_arch;
131
132    # Note: We *always* require an installed dpkg when inferring the
133    # build architecture. The bootstrapping case is handled by
134    # dpkg-architecture itself, by avoiding computing the DEB_BUILD_
135    # variables when they are not requested.
136
137    ## no critic (TestingAndDebugging::ProhibitNoWarnings)
138
65
65
65
65
122
52
4880
    no warnings qw(exec);
139
1
1623
    $build_arch = qx(dpkg --print-architecture);
140
1
50
16
    syserr('dpkg --print-architecture failed') if $? >> 8;
141
142
1
5
    chomp $build_arch;
143
1
16
    return $build_arch;
144}
145
146 - 151
=item $arch = get_build_arch()

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

=cut
152
153sub get_build_arch()
154{
155
17
33
17
1
14
    return Dpkg::Build::Env::get('DEB_BUILD_ARCH') || get_raw_build_arch();
156}
157
158{
159    my %cc_host_gnu_type;
160
161    sub get_host_gnu_type()
162    {
163
4
50
4
0
10
        my $CC = $ENV{CC} || 'gcc';
164
165
4
100
10
        return $cc_host_gnu_type{$CC} if defined $cc_host_gnu_type{$CC};
166
167        ## no critic (TestingAndDebugging::ProhibitNoWarnings)
168
65
65
65
65
130
24
85536
        no warnings qw(exec);
169
3
64305
        $cc_host_gnu_type{$CC} = qx($CC -dumpmachine);
170
3
100
99
        if ($? >> 8) {
171
1
8
            $cc_host_gnu_type{$CC} = '';
172        } else {
173
2
16
            chomp $cc_host_gnu_type{$CC};
174        }
175
176
3
111
        return $cc_host_gnu_type{$CC};
177    }
178
179    sub set_host_gnu_type
180    {
181
1
1
0
1
        my ($host_gnu_type) = @_;
182
1
50
28
        my $CC = $ENV{CC} || 'gcc';
183
184
1
4
        $cc_host_gnu_type{$CC} = $host_gnu_type;
185    }
186}
187
188 - 193
=item $arch = get_raw_host_arch()

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

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

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

=cut
234
235sub get_host_arch()
236{
237
56
33
56
1
69
    return Dpkg::Build::Env::get('DEB_HOST_ARCH') || get_raw_host_arch();
238}
239
240 - 244
=item @arch_list = get_valid_arches()

Get an array with all currently known Debian architectures.

=cut
245
246sub get_valid_arches()
247{
248
1
1
1
1
    _load_cputable();
249
1
3
    _load_ostable();
250
251
1
2
    my @arches;
252
253
1
1
    foreach my $os (@os) {
254
27
16
        foreach my $cpu (@cpu) {
255
999
643
            my $arch = debtuple_to_debarch(split(/-/, $os, 3), $cpu);
256
999
100
792
            push @arches, $arch if defined($arch);
257        }
258    }
259
260
1
53
    return @arches;
261}
262
263my %table_loaded;
264sub _load_table
265{
266
161456
161456
89205
    my ($table, $loader) = @_;
267
268
161456
100
117917
    return if $table_loaded{$table};
269
270
22
17
    local $_;
271
22
34
    local $/ = "\n";
272
273
22
50
306
    open my $table_fh, '<', "$Dpkg::DATADIR/$table"
274        or syserr(g_('cannot open %s'), $table);
275
22
164
    while (<$table_fh>) {
276
1042
546
        $loader->($_);
277    }
278
22
69
    close $table_fh;
279
280
22
64
    $table_loaded{$table} = 1;
281}
282
283sub _load_cputable
284{
285    _load_table('cputable', sub {
286
456
100
456
492
        if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) {
287
296
311
            $cputable{$1} = $2;
288
296
233
            $cputable_re{$1} = $3;
289
296
201
            $cpubits{$1} = $4;
290
296
216
            $cpuendian{$1} = $5;
291
296
358
            push @cpu, $1;
292        }
293
60065
60065
79063
    });
294}
295
296sub _load_ostable
297{
298    _load_table('ostable', sub {
299
90
100
90
92
        if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) {
300
54
58
            $ostable{$1} = $2;
301
54
41
            $ostable_re{$1} = $3;
302
54
59
            push @os, $1;
303        }
304
1151
1151
1064
    });
305}
306
307sub _load_abitable()
308{
309    _load_table('abitable', sub {
310
56
100
56
63
        if (m/^(?!\#)(\S+)\s+(\S+)/) {
311
12
21
            $abibits{$1} = $2;
312        }
313
41326
41326
33469
    });
314}
315
316sub _load_tupletable()
317{
318
58914
58914
40845
    _load_cputable();
319
320    _load_table('tupletable', sub {
321
440
100
440
437
        if (m/^(?!\#)(\S+)\s+(\S+)/) {
322
264
168
            my $debtuple = $1;
323
264
150
            my $debarch = $2;
324
325
264
100
188
            if ($debtuple =~ /<cpu>/) {
326
120
59
                foreach my $_cpu (@cpu) {
327
4440
3102
                    (my $dt = $debtuple) =~ s/<cpu>/$_cpu/;
328
4440
3082
                    (my $da = $debarch) =~ s/<cpu>/$_cpu/;
329
330                    next if exists $debarch_to_debtuple{$da}
331
4440
100
67
5693
                         or exists $debtuple_to_debarch{$dt};
332
333
4408
3103
                    $debarch_to_debtuple{$da} = $dt;
334
4408
4506
                    $debtuple_to_debarch{$dt} = $da;
335                }
336            } else {
337
144
149
                $debarch_to_debtuple{$2} = $1;
338
144
219
                $debtuple_to_debarch{$1} = $2;
339            }
340        }
341
58914
98053
    });
342}
343
344sub debtuple_to_gnutriplet(@)
345{
346
578
578
0
533
    my ($abi, $libc, $os, $cpu) = @_;
347
348
578
463
    _load_cputable();
349
578
1031
    _load_ostable();
350
351    return unless
352        defined $abi && defined $libc && defined $os && defined $cpu &&
353
578
50
14
3550
        exists $cputable{$cpu} && exists $ostable{"$abi-$libc-$os"};
354
578
898
    return join('-', $cputable{$cpu}, $ostable{"$abi-$libc-$os"});
355}
356
357sub gnutriplet_to_debtuple($)
358{
359
573
573
0
329
    my $gnu = shift;
360
573
100
399
    return unless defined($gnu);
361
572
659
    my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2);
362
572
50
33
892
    return unless defined($gnu_cpu) && defined($gnu_os);
363
364
572
396
    _load_cputable();
365
572
720
    _load_ostable();
366
367
572
542
    my ($os, $cpu);
368
369
572
447
    foreach my $_cpu (@cpu) {
370
10739
100
39885
        if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) {
371
571
366
            $cpu = $_cpu;
372
571
403
            last;
373        }
374    }
375
376
572
388
    foreach my $_os (@os) {
377
9534
100
45384
        if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) {
378
571
359
            $os = $_os;
379
571
368
            last;
380        }
381    }
382
383
572
100
67
1059
    return if !defined($cpu) || !defined($os);
384
571
1643
    return (split(/-/, $os, 3), $cpu);
385}
386
387 - 391
=item $multiarch = gnutriplet_to_multiarch($gnutriplet)

Map a GNU triplet into a Debian multiarch triplet.

=cut
392
393sub gnutriplet_to_multiarch($)
394{
395
5
5
1
4
    my $gnu = shift;
396
5
6
    my ($cpu, $cdr) = split(/-/, $gnu, 2);
397
398
5
100
9
    if ($cpu =~ /^i[4567]86$/) {
399
1
3
        return "i386-$cdr";
400    } else {
401
4
8
        return $gnu;
402    }
403}
404
405 - 409
=item $multiarch = debarch_to_multiarch($arch)

Map a Debian architecture into a Debian multiarch triplet.

=cut
410
411sub debarch_to_multiarch($)
412{
413
5
5
1
4
    my $arch = shift;
414
415
5
5
    return gnutriplet_to_multiarch(debarch_to_gnutriplet($arch));
416}
417
418sub debtuple_to_debarch(@)
419{
420
1575
1575
0
1104
    my ($abi, $libc, $os, $cpu) = @_;
421
422
1575
1025
    _load_tupletable();
423
424
1575
100
100
33
5822
    if (!defined $abi || !defined $libc || !defined $os || !defined $cpu) {
425
3
3
        return;
426    } elsif (exists $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}) {
427
1141
1586
        return $debtuple_to_debarch{"$abi-$libc-$os-$cpu"};
428    } else {
429
431
220
        return;
430    }
431}
432
433sub debarch_to_debtuple($)
434{
435
57341
57341
0
28205
    my $arch = shift;
436
437
57341
100
35912
    return if not defined $arch;
438
439
57339
40482
    _load_tupletable();
440
441
57339
100
84721
    if ($arch =~ /^linux-([^-]*)/) {
442        # XXX: Might disappear in the future, not sure yet.
443
6
6
        $arch = $1;
444    }
445
446
57339
35306
    my $tuple = $debarch_to_debtuple{$arch};
447
448
57339
100
34496
    if (defined($tuple)) {
449
57322
42112
        my @tuple = split /-/, $tuple, 4;
450
57322
100
77663
        return @tuple if wantarray;
451        return {
452
3
10
            abi => $tuple[0],
453            libc => $tuple[1],
454            os => $tuple[2],
455            cpu => $tuple[3],
456        };
457    } else {
458
17
322
        return;
459    }
460}
461
462 - 466
=item $gnutriplet = debarch_to_gnutriplet($arch)

Map a Debian architecture into a GNU triplet.

=cut
467
468sub debarch_to_gnutriplet($)
469{
470
8
8
1
4
    my $arch = shift;
471
472
8
6
    return debtuple_to_gnutriplet(debarch_to_debtuple($arch));
473}
474
475 - 479
=item $arch = gnutriplet_to_debarch($gnutriplet)

Map a GNU triplet into a Debian architecture.

=cut
480
481sub gnutriplet_to_debarch($)
482{
483
3
3
1
3
    my $gnu = shift;
484
485
3
3
    return debtuple_to_debarch(gnutriplet_to_debtuple($gnu));
486}
487
488sub debwildcard_to_debtuple($)
489{
490
17445
17445
0
8620
    my $arch = shift;
491
17445
12071
    my @tuple = split /-/, $arch, 4;
492
493
17445
27884
100
27884
21284
17524
    if (any { $_ eq 'any' } @tuple) {
494
17145
100
100
100
12182
        if (scalar @tuple == 4) {
495
10654
13117
            return @tuple;
496        } elsif (scalar @tuple == 3) {
497
4725
5673
            return ('any', @tuple);
498        } elsif (scalar @tuple == 2) {
499
1765
2097
            return ('any', 'any', @tuple);
500        } else {
501
1
2
            return ('any', 'any', 'any', 'any');
502        }
503    } else {
504
300
204
        return debarch_to_debtuple($arch);
505    }
506}
507
508sub debarch_to_abiattrs($)
509{
510
41327
41327
0
21310
    my $arch = shift;
511
41327
23310
    my ($abi, $libc, $os, $cpu) = debarch_to_debtuple($arch);
512
513
41327
100
25866
    if (defined($cpu)) {
514
41326
29098
        _load_abitable();
515
516
41326
67
76758
        return ($abibits{$abi} // $cpubits{$cpu}, $cpuendian{$cpu});
517    } else {
518
1
2
        return;
519    }
520}
521
522sub debarch_to_cpubits($)
523{
524
3
3
0
3
    my $arch = shift;
525
3
2
    my (undef, undef, undef, $cpu) = debarch_to_debtuple($arch);
526
527
3
100
3
    if (defined $cpu) {
528
2
3
        return $cpubits{$cpu};
529    } else {
530
1
2
        return;
531    }
532}
533
534 - 539
=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
540
541sub debarch_eq($$)
542{
543
10
10
1
7
    my ($a, $b) = @_;
544
545
10
100
12
    return 1 if ($a eq $b);
546
547
7
3
    my @a = debarch_to_debtuple($a);
548
7
7
    my @b = debarch_to_debtuple($b);
549
550
7
100
100
19
    return 0 if scalar @a != 4 or scalar @b != 4;
551
552
3
67
14
    return $a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2] && $a[3] eq $b[3];
553}
554
555 - 560
=item $bool = debarch_is($arch, $arch_wildcard)

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

=cut
561
562sub debarch_is($$)
563{
564
15171
15171
1
10122
    my ($real, $alias) = @_;
565
566
15171
100
100
26455
    return 1 if ($alias eq $real or $alias eq 'any');
567
568
14529
9415
    my @real = debarch_to_debtuple($real);
569
14529
9995
    my @alias = debwildcard_to_debtuple($alias);
570
571
14529
100
100
27539
    return 0 if scalar @real != 4 or scalar @alias != 4;
572
573
14526
100
90
59810
    if (($alias[0] eq $real[0] || $alias[0] eq 'any') &&
574        ($alias[1] eq $real[1] || $alias[1] eq 'any') &&
575        ($alias[2] eq $real[2] || $alias[2] eq 'any') &&
576        ($alias[3] eq $real[3] || $alias[3] eq 'any')) {
577
14227
19446
        return 1;
578    }
579
580
299
341
    return 0;
581}
582
583 - 587
=item $bool = debarch_is_wildcard($arch)

Evaluate whether a Debian architecture is an architecture wildcard.

=cut
588
589sub debarch_is_wildcard($)
590{
591
2917
2917
1
1714
    my $arch = shift;
592
593
2917
100
2204
    return 0 if $arch eq 'all';
594
595
2916
1686
    my @tuple = debwildcard_to_debtuple($arch);
596
597
2916
100
3530
    return 0 if scalar @tuple != 4;
598
2915
4009
100
4009
2958
5085
    return 1 if any { $_ eq 'any' } @tuple;
599
1
2
    return 0;
600}
601
602 - 609
=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
610
611sub debarch_is_illegal
612{
613
33
33
1
26
    my ($arch, %opts) = @_;
614
33
29
    my $arch_re = qr/[a-zA-Z0-9][a-zA-Z0-9-]*/;
615
616
33
100
22
    if ($opts{positive}) {
617
6
24
        return $arch !~ m/^$arch_re$/;
618    } else {
619
27
105
        return $arch !~ m/^!?$arch_re$/;
620    }
621}
622
623 - 628
=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
629
630sub debarch_is_concerned
631{
632
175
175
1
203
    my ($host_arch, @arches) = @_;
633
634
175
103
    my $seen_arch = 0;
635
175
135
    foreach my $arch (@arches) {
636
369
222
        $arch = lc $arch;
637
638
369
100
100
342
        if ($arch =~ /^!/) {
639
221
139
            my $not_arch = $arch;
640
221
191
            $not_arch =~ s/^!//;
641
642
221
100
164
            if (debarch_is($host_arch, $not_arch)) {
643
44
26
                $seen_arch = 0;
644
44
32
                last;
645            } else {
646                # !arch includes by default all other arches
647                # unless they also appear in a !otherarch
648
177
119
                $seen_arch = 1;
649            }
650        } elsif (debarch_is($host_arch, $arch)) {
651
28
15
            $seen_arch = 1;
652
28
22
            last;
653        }
654    }
655
175
433
    return $seen_arch;
656}
657
658 - 665
=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
666
667sub debarch_list_parse
668{
669
14
14
1
11
    my ($arch_list, %opts) = @_;
670
14
14
    my @arch_list = split ' ', $arch_list;
671
672
14
10
    foreach my $arch (@arch_list) {
673
24
100
18
        if (debarch_is_illegal($arch, %opts)) {
674
2
19
            error(g_("'%s' is not a legal architecture in list '%s'"),
675                  $arch, $arch_list);
676        }
677    }
678
679
12
17
    return @arch_list;
680}
681
6821;
683
684=back
685
686 - 707
=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

dpkg-architecture(1).