File Coverage

File:dpkg-architecture.pl
Coverage:42.3%

linestmtbrancondsubpodtimecode
1#!/usr/bin/perl
2#
3# dpkg-architecture
4#
5# Copyright © 1999-2001 Marcus Brinkmann <brinkmd@debian.org>
6# Copyright © 2004-2005 Scott James Remnant <scott@netsplit.com>,
7# Copyright © 2006-2014 Guillem Jover <guillem@debian.org>
8#
9# This program is free software; you can redistribute it and/or modify
10# it under the terms of the GNU General Public License as published by
11# the Free Software Foundation; either version 2 of the License, or
12# (at your option) any later version.
13#
14# This program is distributed in the hope that it will be useful,
15# but WITHOUT ANY WARRANTY; without even the implied warranty of
16# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17# GNU General Public License for more details.
18#
19# You should have received a copy of the GNU General Public License
20# along with this program.  If not, see <https://www.gnu.org/licenses/>.
21
22
1
1
1
1
1618
0
14
use strict;
23
1
1
1
1
2
1
16
use warnings;
24
25
1
1
1
1
110
1
10
use Dpkg ();
26
1
1
1
1
117
1
24
use Dpkg::Gettext;
27
1
1
1
1
120
1
19
use Dpkg::Getopt;
28
1
1
1
1
115
1
31
use Dpkg::ErrorHandling;
29
1
1
1
1
130
1
235
use Dpkg::Arch qw(:getters :mappers debarch_eq debarch_is);
30
31
1
26658
textdomain('dpkg-dev');
32
33sub version {
34
0
0
0
    printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION;
35
36
0
0
    printf g_('
37This is free software; see the GNU General Public License version 2 or
38later for copying conditions. There is NO warranty.
39');
40}
41
42sub usage {
43
0
0
0
    printf g_(
44'Usage: %s [<option>...] [<command>]')
45    . "\n\n" . g_(
46'Commands:
47  -l, --list                list variables (default).
48  -L, --list-known          list valid architectures (matching some criteria).
49  -e, --equal <arch>        compare with host Debian architecture.
50  -i, --is <arch-wildcard>  match against host Debian architecture.
51  -q, --query <variable>    prints only the value of <variable>.
52  -s, --print-set           print command to set environment variables.
53  -u, --print-unset         print command to unset environment variables.
54  -c, --command <command>   set environment and run the command in it.
55  -?, --help                show this help message.
56      --version             show the version.')
57    . "\n\n" . g_(
58'Options:
59  -a, --host-arch <arch>    set host Debian architecture.
60  -t, --host-type <type>    set host GNU system type.
61  -A, --target-arch <arch>  set target Debian architecture.
62  -T, --target-type <type>  set target GNU system type.
63  -W, --match-wildcard <arch-wildcard>
64                            restrict architecture list matching <arch-wildcard>.
65  -B, --match-bits <arch-bits>
66                            restrict architecture list matching <arch-bits>.
67  -E, --match-endian <arch-endian>
68                            restrict architecture list matching <arch-endian>.
69      --print-format <format>
70                            use <format> for --print-set and --print-unset,
71                              allowed values: shell (default), make.
72  -f, --force               force flag (override variables set in environment).')
73    . "\n", $Dpkg::PROGNAME;
74}
75
76sub check_arch_coherency
77{
78
2
2
8
    my ($arch, $gnu_type) = @_;
79
80
2
50
33
3
    if ($arch ne '' && $gnu_type eq '') {
81
0
0
        $gnu_type = debarch_to_gnutriplet($arch);
82
0
0
0
        error(g_('unknown Debian architecture %s, you must specify ' .
83                 'GNU system type, too'), $arch)
84            unless defined $gnu_type;
85    }
86
87
2
50
33
3
    if ($gnu_type ne '' && $arch eq '') {
88
0
0
        $arch = gnutriplet_to_debarch($gnu_type);
89
0
0
0
        error(g_('unknown GNU system type %s, you must specify ' .
90                 'Debian architecture, too'), $gnu_type)
91            unless defined $arch;
92    }
93
94
2
50
33
2
    if ($gnu_type ne '' && $arch ne '') {
95
0
0
        my $dfl_gnu_type = debarch_to_gnutriplet($arch);
96
0
0
0
        error(g_('unknown default GNU system type for Debian architecture %s'),
97              $arch)
98            unless defined $dfl_gnu_type;
99
0
0
0
        warning(g_('default GNU system type %s for Debian arch %s does not ' .
100                   'match specified GNU system type %s'), $dfl_gnu_type,
101                $arch, $gnu_type)
102            if $dfl_gnu_type ne $gnu_type;
103    }
104
105
2
5
    return ($arch, $gnu_type);
106}
107
108use constant {
109
1
572
    DEB_NONE                    => 0,
110
111    DEB_BUILD_INFO              => 0b00001,
112    DEB_BUILD_ARCH_INFO         => 0b00010,
113    DEB_BUILD_ARCH_ATTR         => 0b00100,
114    DEB_BUILD_MULTIARCH_INFO    => 0b01000,
115    DEB_BUILD_GNU_INFO          => 0b10000,
116    DEB_BUILD_ANY               => 0b11111,
117
118    DEB_HOST_INFO               => 0b0000100000,
119    DEB_HOST_ARCH_INFO          => 0b0001000000,
120    DEB_HOST_ARCH_ATTR          => 0b0010000000,
121    DEB_HOST_MULTIARCH_INFO     => 0b0100000000,
122    DEB_HOST_GNU_INFO           => 0b1000000000,
123    DEB_HOST_ANY                => 0b1111100000,
124
125    DEB_TARGET_INFO             => 0b000010000000000,
126    DEB_TARGET_ARCH_INFO        => 0b000100000000000,
127    DEB_TARGET_ARCH_ATTR        => 0b001000000000000,
128    DEB_TARGET_MULTIARCH_INFO   => 0b010000000000000,
129    DEB_TARGET_GNU_INFO         => 0b100000000000000,
130    DEB_TARGET_ANY              => 0b111110000000000,
131
132    DEB_ALL                     => 0b111111111111111,
133
1
1
1
3
1
};
134
135
1
2
my %arch_deps = (
136    DEB_BUILD_ANY+0 => DEB_BUILD_INFO,
137    DEB_HOST_ANY+0 => DEB_HOST_INFO,
138    DEB_TARGET_ANY+0 => DEB_TARGET_INFO,
139);
140
141
1
10
my %arch_vars = (
142    DEB_BUILD_ARCH => DEB_BUILD_INFO,
143    DEB_BUILD_ARCH_ABI => DEB_BUILD_ARCH_INFO,
144    DEB_BUILD_ARCH_LIBC => DEB_BUILD_ARCH_INFO,
145    DEB_BUILD_ARCH_OS => DEB_BUILD_ARCH_INFO,
146    DEB_BUILD_ARCH_CPU => DEB_BUILD_ARCH_INFO,
147    DEB_BUILD_ARCH_BITS => DEB_BUILD_ARCH_ATTR,
148    DEB_BUILD_ARCH_ENDIAN => DEB_BUILD_ARCH_ATTR,
149    DEB_BUILD_MULTIARCH => DEB_BUILD_MULTIARCH_INFO,
150    DEB_BUILD_GNU_CPU => DEB_BUILD_GNU_INFO,
151    DEB_BUILD_GNU_SYSTEM => DEB_BUILD_GNU_INFO,
152    DEB_BUILD_GNU_TYPE => DEB_BUILD_GNU_INFO,
153    DEB_HOST_ARCH => DEB_HOST_INFO,
154    DEB_HOST_ARCH_ABI => DEB_HOST_ARCH_INFO,
155    DEB_HOST_ARCH_LIBC => DEB_HOST_ARCH_INFO,
156    DEB_HOST_ARCH_OS => DEB_HOST_ARCH_INFO,
157    DEB_HOST_ARCH_CPU => DEB_HOST_ARCH_INFO,
158    DEB_HOST_ARCH_BITS => DEB_HOST_ARCH_ATTR,
159    DEB_HOST_ARCH_ENDIAN => DEB_HOST_ARCH_ATTR,
160    DEB_HOST_MULTIARCH => DEB_HOST_MULTIARCH_INFO,
161    DEB_HOST_GNU_CPU => DEB_HOST_GNU_INFO,
162    DEB_HOST_GNU_SYSTEM => DEB_HOST_GNU_INFO,
163    DEB_HOST_GNU_TYPE => DEB_HOST_GNU_INFO,
164    DEB_TARGET_ARCH => DEB_TARGET_INFO,
165    DEB_TARGET_ARCH_ABI => DEB_TARGET_ARCH_INFO,
166    DEB_TARGET_ARCH_LIBC => DEB_TARGET_ARCH_INFO,
167    DEB_TARGET_ARCH_OS => DEB_TARGET_ARCH_INFO,
168    DEB_TARGET_ARCH_CPU => DEB_TARGET_ARCH_INFO,
169    DEB_TARGET_ARCH_BITS => DEB_TARGET_ARCH_ATTR,
170    DEB_TARGET_ARCH_ENDIAN => DEB_TARGET_ARCH_ATTR,
171    DEB_TARGET_MULTIARCH => DEB_TARGET_MULTIARCH_INFO,
172    DEB_TARGET_GNU_CPU => DEB_TARGET_GNU_INFO,
173    DEB_TARGET_GNU_SYSTEM => DEB_TARGET_GNU_INFO,
174    DEB_TARGET_GNU_TYPE => DEB_TARGET_GNU_INFO,
175);
176
177
1
2
2
3
my %known_print_format = map { $_ => 1 } qw(shell make);
178
1
1
my $print_format = 'shell';
179
180
1
1
my $req_vars = DEB_ALL;
181
1
1
my $req_host_arch = '';
182
1
0
my $req_host_gnu_type = '';
183
1
1
my $req_target_arch = '';
184
1
1
my $req_target_gnu_type = '';
185
1
1
my $req_eq_arch = '';
186
1
1
my $req_is_arch = '';
187
1
0
my $req_match_wildcard = '';
188
1
2
my $req_match_bits = '';
189
1
0
my $req_match_endian = '';
190
1
1
my $req_variable_to_print;
191
1
0
my $action = 'list';
192
1
1
my $force = 0;
193
194sub action_needs($) {
195
15
15
13
  my $bits = shift;
196
15
46
  return (($req_vars & $bits) == $bits);
197}
198
199
1
2
@ARGV = normalize_options(args => \@ARGV, delim => '-c');
200
201
1
2
while (@ARGV) {
202
1
1
    my $arg = shift;
203
204
1
50
50
50
50
50
50
50
50
50
50
50
50
50
50
0
0
0
0
0
19
    if ($arg eq '-a' or $arg eq '--host-arch') {
205
0
0
        $req_host_arch = shift;
206    } elsif ($arg eq '-t' or $arg eq '--host-type') {
207
0
0
        $req_host_gnu_type = shift;
208    } elsif ($arg eq '-A' or $arg eq '--target-arch') {
209
0
0
        $req_target_arch = shift;
210    } elsif ($arg eq '-T' or $arg eq '--target-type') {
211
0
0
        $req_target_gnu_type = shift;
212    } elsif ($arg eq '-W' or $arg eq '--match-wildcard') {
213
0
0
        $req_match_wildcard = shift;
214    } elsif ($arg eq '-B' or $arg eq '--match-bits') {
215
0
0
        $req_match_bits = shift;
216    } elsif ($arg eq '-E' or $arg eq '--match-endian') {
217
0
0
        $req_match_endian = shift;
218    } elsif ($arg eq '-e' or $arg eq '--equal') {
219
0
0
        $req_eq_arch = shift;
220
0
0
        $req_vars = $arch_vars{DEB_HOST_ARCH};
221
0
0
        $action = 'equal';
222    } elsif ($arg eq '-i' or $arg eq '--is') {
223
0
0
        $req_is_arch = shift;
224
0
0
        $req_vars = $arch_vars{DEB_HOST_ARCH};
225
0
0
        $action = 'is';
226    } elsif ($arg eq '-u' or $arg eq '--print-unset') {
227
0
0
        $req_vars = DEB_NONE;
228
0
0
        $action = 'print-unset';
229    } elsif ($arg eq '-l' or $arg eq '--list') {
230
0
0
        $action = 'list';
231    } elsif ($arg eq '-s' or $arg eq '--print-set') {
232
0
0
        $req_vars = DEB_ALL;
233
0
0
        $action = 'print-set';
234    } elsif ($arg eq '--print-format') {
235
0
0
        $print_format = shift;
236        error(g_('%s is not a supported print format'), $print_format)
237
0
0
0
            unless exists $known_print_format{$print_format};
238    } elsif ($arg eq '-f' or $arg eq '--force') {
239
1
2
        $force=1;
240    } elsif ($arg eq '-q' or $arg eq '--query') {
241
0
0
        my $varname = shift;
242        error(g_('%s is not a supported variable name'), $varname)
243
0
0
0
            unless (exists $arch_vars{$varname});
244
0
0
        $req_variable_to_print = "$varname";
245
0
0
        $req_vars = $arch_vars{$varname};
246
0
0
        $action = 'query';
247    } elsif ($arg eq '-c' or $arg eq '--command') {
248
0
0
       $action = 'command';
249
0
0
       last;
250    } elsif ($arg eq '-L' or $arg eq '--list-known') {
251
0
0
        $req_vars = 0;
252
0
0
        $action = 'list-known';
253    } elsif ($arg eq '-?' or $arg eq '--help') {
254
0
0
        usage();
255
0
0
       exit 0;
256    } elsif ($arg eq '--version') {
257
0
0
        version();
258
0
0
       exit 0;
259    } else {
260
0
0
        usageerr(g_("unknown option '%s'"), $arg);
261    }
262}
263
264# Handle variable dependencies
265
1
1
foreach my $k (keys %arch_deps) {
266
3
50
6
    if ($req_vars & $k) {
267
3
3
        $req_vars |= $arch_deps{$k};
268    }
269}
270
271
1
1
my %v;
272
273
1
2
foreach my $k (keys %arch_vars) {
274
33
50
33
26
    next if not length $ENV{$k} or $force;
275
0
0
    $v{$k} = $ENV{$k};
276
0
0
    $req_vars &= ~$arch_vars{$k};
277}
278
279#
280# Set build variables
281#
282
283
1
50
2
$v{DEB_BUILD_ARCH} = get_raw_build_arch()
284    if (action_needs(DEB_BUILD_INFO));
285($v{DEB_BUILD_ARCH_ABI}, $v{DEB_BUILD_ARCH_LIBC},
286 $v{DEB_BUILD_ARCH_OS}, $v{DEB_BUILD_ARCH_CPU}) = debarch_to_debtuple($v{DEB_BUILD_ARCH})
287
1
50
10
    if (action_needs(DEB_BUILD_ARCH_INFO));
288($v{DEB_BUILD_ARCH_BITS}, $v{DEB_BUILD_ARCH_ENDIAN}) = debarch_to_abiattrs($v{DEB_BUILD_ARCH})
289
1
50
2
    if (action_needs(DEB_BUILD_ARCH_ATTR));
290
291$v{DEB_BUILD_MULTIARCH} = debarch_to_multiarch($v{DEB_BUILD_ARCH})
292
1
50
1
    if (action_needs(DEB_BUILD_MULTIARCH_INFO));
293
294
1
50
1
if (action_needs(DEB_BUILD_GNU_INFO)) {
295
1
2
  $v{DEB_BUILD_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_BUILD_ARCH});
296
1
3
  ($v{DEB_BUILD_GNU_CPU}, $v{DEB_BUILD_GNU_SYSTEM}) = split(/-/, $v{DEB_BUILD_GNU_TYPE}, 2);
297}
298
299#
300# Set host variables
301#
302
303# First perform some sanity checks on the host arguments passed.
304
305
1
2
($req_host_arch, $req_host_gnu_type) = check_arch_coherency($req_host_arch, $req_host_gnu_type);
306
307# Proceed to compute the host variables if needed.
308
309
1
50
33
1
$v{DEB_HOST_ARCH} = $req_host_arch || get_raw_host_arch()
310    if (action_needs(DEB_HOST_INFO));
311($v{DEB_HOST_ARCH_ABI}, $v{DEB_HOST_ARCH_LIBC},
312 $v{DEB_HOST_ARCH_OS}, $v{DEB_HOST_ARCH_CPU}) = debarch_to_debtuple($v{DEB_HOST_ARCH})
313
1
50
7
    if (action_needs(DEB_HOST_ARCH_INFO));
314($v{DEB_HOST_ARCH_BITS}, $v{DEB_HOST_ARCH_ENDIAN}) = debarch_to_abiattrs($v{DEB_HOST_ARCH})
315
1
50
2
    if (action_needs(DEB_HOST_ARCH_ATTR));
316
317$v{DEB_HOST_MULTIARCH} = debarch_to_multiarch($v{DEB_HOST_ARCH})
318
1
50
1
    if (action_needs(DEB_HOST_MULTIARCH_INFO));
319
320
1
50
14
if (action_needs(DEB_HOST_GNU_INFO)) {
321
1
50
2
    if ($req_host_gnu_type eq '') {
322
1
1
        $v{DEB_HOST_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_HOST_ARCH});
323    } else {
324
0
0
        $v{DEB_HOST_GNU_TYPE} = $req_host_gnu_type;
325    }
326
1
4
    ($v{DEB_HOST_GNU_CPU}, $v{DEB_HOST_GNU_SYSTEM}) = split(/-/, $v{DEB_HOST_GNU_TYPE}, 2);
327
328
1
1
    my $host_gnu_type = get_host_gnu_type();
329
330    warning(g_('specified GNU system type %s does not match CC system ' .
331               'type %s, try setting a correct CC environment variable'),
332            $v{DEB_HOST_GNU_TYPE}, $host_gnu_type)
333
1
50
33
8
        if ($host_gnu_type ne '') && ($host_gnu_type ne $v{DEB_HOST_GNU_TYPE});
334}
335
336#
337# Set target variables
338#
339
340# First perform some sanity checks on the target arguments passed.
341
342
1
2
($req_target_arch, $req_target_gnu_type) = check_arch_coherency($req_target_arch, $req_target_gnu_type);
343
344# Proceed to compute the target variables if needed.
345
346
1
50
33
1
$v{DEB_TARGET_ARCH} = $req_target_arch || $v{DEB_HOST_ARCH} || $req_host_arch || get_raw_host_arch()
347    if (action_needs(DEB_TARGET_INFO));
348($v{DEB_TARGET_ARCH_ABI}, $v{DEB_TARGET_ARCH_LIBC},
349 $v{DEB_TARGET_ARCH_OS}, $v{DEB_TARGET_ARCH_CPU}) = debarch_to_debtuple($v{DEB_TARGET_ARCH})
350
1
50
1
    if (action_needs(DEB_TARGET_ARCH_INFO));
351($v{DEB_TARGET_ARCH_BITS}, $v{DEB_TARGET_ARCH_ENDIAN}) = debarch_to_abiattrs($v{DEB_TARGET_ARCH})
352
1
50
1
    if (action_needs(DEB_TARGET_ARCH_ATTR));
353
354$v{DEB_TARGET_MULTIARCH} = debarch_to_multiarch($v{DEB_TARGET_ARCH})
355
1
50
1
    if (action_needs(DEB_TARGET_MULTIARCH_INFO));
356
357
1
50
2
if (action_needs(DEB_TARGET_GNU_INFO)) {
358
1
50
1
    if ($req_target_gnu_type eq '') {
359
1
1
        $v{DEB_TARGET_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_TARGET_ARCH});
360    } else {
361
0
0
        $v{DEB_TARGET_GNU_TYPE} = $req_target_gnu_type;
362    }
363
1
2
    ($v{DEB_TARGET_GNU_CPU}, $v{DEB_TARGET_GNU_SYSTEM}) = split(/-/, $v{DEB_TARGET_GNU_TYPE}, 2);
364}
365
366
367
1
50
0
0
0
0
0
0
0
1
if ($action eq 'list') {
368
1
16
    foreach my $k (sort keys %arch_vars) {
369
33
24
        print "$k=$v{$k}\n";
370    }
371} elsif ($action eq 'print-set') {
372
0
0
0
0
    if ($print_format eq 'shell') {
373
0
0
        foreach my $k (sort keys %arch_vars) {
374
0
0
            print "$k=$v{$k}; ";
375        }
376
0
0
        print 'export ' . join(' ', sort keys %arch_vars) . "\n";
377    } elsif ($print_format eq 'make') {
378
0
0
        foreach my $k (sort keys %arch_vars) {
379
0
0
            print "export $k = $v{$k}\n";
380        }
381    }
382} elsif ($action eq 'print-unset') {
383
0
0
0
0
    if ($print_format eq 'shell') {
384
0
0
        print 'unset ' . join(' ', sort keys %arch_vars) . "\n";
385    } elsif ($print_format eq 'make') {
386
0
0
        foreach my $k (sort keys %arch_vars) {
387
0
0
            print "undefine $k\n";
388        }
389    }
390} elsif ($action eq 'equal') {
391
0
0
    exit !debarch_eq($v{DEB_HOST_ARCH}, $req_eq_arch);
392} elsif ($action eq 'is') {
393
0
0
    exit !debarch_is($v{DEB_HOST_ARCH}, $req_is_arch);
394} elsif ($action eq 'command') {
395
0
0
    @ENV{keys %v} = values %v;
396    ## no critic (TestingAndDebugging::ProhibitNoWarnings)
397
1
1
1
1
3
6
765
    no warnings qw(exec);
398
0
0
0
    exec @ARGV or syserr(g_('unable to execute %s'), "@ARGV");
399} elsif ($action eq 'query') {
400
0
0
    print "$v{$req_variable_to_print}\n";
401} elsif ($action eq 'list-known') {
402
0
0
    foreach my $arch (get_valid_arches()) {
403
0
0
        my ($bits, $endian) = debarch_to_abiattrs($arch);
404
405
0
0
0
0
        next if $req_match_endian and $endian ne $req_match_endian;
406
0
0
0
0
        next if $req_match_bits and $bits ne $req_match_bits;
407
0
0
0
0
        next if $req_match_wildcard and not debarch_is($arch, $req_match_wildcard);
408
409
0
0
        print "$arch\n";
410    }
411}