File Coverage

File:dpkg-architecture.pl
Coverage:42.0%

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
3
3
3
3
5362
1
48
use strict;
23
3
3
3
3
5
2
61
use warnings;
24
25
3
3
3
3
357
2
32
use Dpkg ();
26
3
3
3
3
317
4
93
use Dpkg::Gettext;
27
3
3
3
3
420
9
99
use Dpkg::Getopt;
28
3
3
3
3
479
3
112
use Dpkg::ErrorHandling;
29
3
3
3
3
438
4
751
use Dpkg::Arch qw(:getters :mappers debarch_eq debarch_is);
30
31
3
98850
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
6
6
13
    my ($arch, $gnu_type) = @_;
79
80
6
50
33
8
    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
6
50
33
10
    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
6
50
33
5
    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
6
14
    return ($arch, $gnu_type);
106}
107
108use constant {
109
3
1904
    INFO_BUILD_ARCH_NAME        => 0b00001,
110    INFO_BUILD_ARCH_TUPLE       => 0b00010,
111    INFO_BUILD_ARCH_ATTR        => 0b00100,
112    INFO_BUILD_MULTIARCH        => 0b01000,
113    INFO_BUILD_GNU_TUPLE        => 0b10000,
114
115    INFO_HOST_ARCH_NAME         => 0b0000100000,
116    INFO_HOST_ARCH_TUPLE        => 0b0001000000,
117    INFO_HOST_ARCH_ATTR         => 0b0010000000,
118    INFO_HOST_MULTIARCH         => 0b0100000000,
119    INFO_HOST_GNU_TUPLE         => 0b1000000000,
120
121    INFO_TARGET_ARCH_NAME       => 0b000010000000000,
122    INFO_TARGET_ARCH_TUPLE      => 0b000100000000000,
123    INFO_TARGET_ARCH_ATTR       => 0b001000000000000,
124    INFO_TARGET_MULTIARCH       => 0b010000000000000,
125    INFO_TARGET_GNU_TUPLE       => 0b100000000000000,
126
3
3
3
7
2
};
127
128
3
44
my %arch_vars = (
129    DEB_BUILD_ARCH          => INFO_BUILD_ARCH_NAME,
130    DEB_BUILD_ARCH_ABI      => INFO_BUILD_ARCH_NAME | INFO_BUILD_ARCH_TUPLE,
131    DEB_BUILD_ARCH_LIBC     => INFO_BUILD_ARCH_NAME | INFO_BUILD_ARCH_TUPLE,
132    DEB_BUILD_ARCH_OS       => INFO_BUILD_ARCH_NAME | INFO_BUILD_ARCH_TUPLE,
133    DEB_BUILD_ARCH_CPU      => INFO_BUILD_ARCH_NAME | INFO_BUILD_ARCH_TUPLE,
134    DEB_BUILD_ARCH_BITS     => INFO_BUILD_ARCH_NAME | INFO_BUILD_ARCH_ATTR,
135    DEB_BUILD_ARCH_ENDIAN   => INFO_BUILD_ARCH_NAME | INFO_BUILD_ARCH_ATTR,
136    DEB_BUILD_MULTIARCH     => INFO_BUILD_ARCH_NAME | INFO_BUILD_MULTIARCH,
137    DEB_BUILD_GNU_CPU       => INFO_BUILD_ARCH_NAME | INFO_BUILD_GNU_TUPLE,
138    DEB_BUILD_GNU_SYSTEM    => INFO_BUILD_ARCH_NAME | INFO_BUILD_GNU_TUPLE,
139    DEB_BUILD_GNU_TYPE      => INFO_BUILD_ARCH_NAME | INFO_BUILD_GNU_TUPLE,
140    DEB_HOST_ARCH           => INFO_HOST_ARCH_NAME,
141    DEB_HOST_ARCH_ABI       => INFO_HOST_ARCH_NAME | INFO_HOST_ARCH_TUPLE,
142    DEB_HOST_ARCH_LIBC      => INFO_HOST_ARCH_NAME | INFO_HOST_ARCH_TUPLE,
143    DEB_HOST_ARCH_OS        => INFO_HOST_ARCH_NAME | INFO_HOST_ARCH_TUPLE,
144    DEB_HOST_ARCH_CPU       => INFO_HOST_ARCH_NAME | INFO_HOST_ARCH_TUPLE,
145    DEB_HOST_ARCH_BITS      => INFO_HOST_ARCH_NAME | INFO_HOST_ARCH_ATTR,
146    DEB_HOST_ARCH_ENDIAN    => INFO_HOST_ARCH_NAME | INFO_HOST_ARCH_ATTR,
147    DEB_HOST_MULTIARCH      => INFO_HOST_ARCH_NAME | INFO_HOST_MULTIARCH,
148    DEB_HOST_GNU_CPU        => INFO_HOST_ARCH_NAME | INFO_HOST_GNU_TUPLE,
149    DEB_HOST_GNU_SYSTEM     => INFO_HOST_ARCH_NAME | INFO_HOST_GNU_TUPLE,
150    DEB_HOST_GNU_TYPE       => INFO_HOST_ARCH_NAME | INFO_HOST_GNU_TUPLE,
151    DEB_TARGET_ARCH         => INFO_TARGET_ARCH_NAME,
152    DEB_TARGET_ARCH_ABI     => INFO_TARGET_ARCH_NAME | INFO_TARGET_ARCH_TUPLE,
153    DEB_TARGET_ARCH_LIBC    => INFO_TARGET_ARCH_NAME | INFO_TARGET_ARCH_TUPLE,
154    DEB_TARGET_ARCH_OS      => INFO_TARGET_ARCH_NAME | INFO_TARGET_ARCH_TUPLE,
155    DEB_TARGET_ARCH_CPU     => INFO_TARGET_ARCH_NAME | INFO_TARGET_ARCH_TUPLE,
156    DEB_TARGET_ARCH_BITS    => INFO_TARGET_ARCH_NAME | INFO_TARGET_ARCH_ATTR,
157    DEB_TARGET_ARCH_ENDIAN  => INFO_TARGET_ARCH_NAME | INFO_TARGET_ARCH_ATTR,
158    DEB_TARGET_MULTIARCH    => INFO_TARGET_ARCH_NAME | INFO_TARGET_MULTIARCH,
159    DEB_TARGET_GNU_CPU      => INFO_TARGET_ARCH_NAME | INFO_TARGET_GNU_TUPLE,
160    DEB_TARGET_GNU_SYSTEM   => INFO_TARGET_ARCH_NAME | INFO_TARGET_GNU_TUPLE,
161    DEB_TARGET_GNU_TYPE     => INFO_TARGET_ARCH_NAME | INFO_TARGET_GNU_TUPLE,
162);
163
164
3
6
3
9
my %known_print_format = map { $_ => 1 } qw(shell make);
165
3
13
my $print_format = 'shell';
166
167
3
27
my %req_vars = %arch_vars;
168
3
5
my $req_info = 0;
169
3
8
my $req_host_arch = '';
170
3
3
my $req_host_gnu_type = '';
171
3
2
my $req_target_arch = '';
172
3
1
my $req_target_gnu_type = '';
173
3
2
my $req_eq_arch = '';
174
3
3
my $req_is_arch = '';
175
3
1
my $req_match_wildcard = '';
176
3
2
my $req_match_bits = '';
177
3
1
my $req_match_endian = '';
178
3
3
my $req_variable_to_print;
179
3
1
my $action = 'list';
180
3
2
my $force = 0;
181
182sub action_needs($) {
183
45
45
33
    my $bits = shift;
184
45
155
    return (($req_info & $bits) == $bits);
185}
186
187
3
7
@ARGV = normalize_options(args => \@ARGV, delim => '-c');
188
189
3
5
while (@ARGV) {
190
3
3
    my $arg = shift;
191
192
3
50
50
50
50
50
50
50
50
50
50
50
50
50
50
0
0
0
0
0
63
    if ($arg eq '-a' or $arg eq '--host-arch') {
193
0
0
        $req_host_arch = shift;
194    } elsif ($arg eq '-t' or $arg eq '--host-type') {
195
0
0
        $req_host_gnu_type = shift;
196    } elsif ($arg eq '-A' or $arg eq '--target-arch') {
197
0
0
        $req_target_arch = shift;
198    } elsif ($arg eq '-T' or $arg eq '--target-type') {
199
0
0
        $req_target_gnu_type = shift;
200    } elsif ($arg eq '-W' or $arg eq '--match-wildcard') {
201
0
0
        $req_match_wildcard = shift;
202    } elsif ($arg eq '-B' or $arg eq '--match-bits') {
203
0
0
        $req_match_bits = shift;
204    } elsif ($arg eq '-E' or $arg eq '--match-endian') {
205
0
0
        $req_match_endian = shift;
206    } elsif ($arg eq '-e' or $arg eq '--equal') {
207
0
0
        $req_eq_arch = shift;
208
0
0
        %req_vars = %arch_vars{DEB_HOST_ARCH};
209
0
0
        $action = 'equal';
210    } elsif ($arg eq '-i' or $arg eq '--is') {
211
0
0
        $req_is_arch = shift;
212
0
0
        %req_vars = %arch_vars{DEB_HOST_ARCH};
213
0
0
        $action = 'is';
214    } elsif ($arg eq '-u' or $arg eq '--print-unset') {
215
0
0
        %req_vars = ();
216
0
0
        $action = 'print-unset';
217    } elsif ($arg eq '-l' or $arg eq '--list') {
218
0
0
        $action = 'list';
219    } elsif ($arg eq '-s' or $arg eq '--print-set') {
220
0
0
        %req_vars = %arch_vars;
221
0
0
        $action = 'print-set';
222    } elsif ($arg eq '--print-format') {
223
0
0
        $print_format = shift;
224        error(g_('%s is not a supported print format'), $print_format)
225
0
0
0
            unless exists $known_print_format{$print_format};
226    } elsif ($arg eq '-f' or $arg eq '--force') {
227
3
4
        $force = 1;
228    } elsif ($arg eq '-q' or $arg eq '--query') {
229
0
0
        my $varname = shift;
230        error(g_('%s is not a supported variable name'), $varname)
231
0
0
0
            unless (exists $arch_vars{$varname});
232
0
0
        $req_variable_to_print = "$varname";
233
0
0
        %req_vars = %arch_vars{$varname};
234
0
0
        $action = 'query';
235    } elsif ($arg eq '-c' or $arg eq '--command') {
236
0
0
        $action = 'command';
237
0
0
        last;
238    } elsif ($arg eq '-L' or $arg eq '--list-known') {
239
0
0
        %req_vars = ();
240
0
0
        $action = 'list-known';
241    } elsif ($arg eq '-?' or $arg eq '--help') {
242
0
0
        usage();
243
0
0
       exit 0;
244    } elsif ($arg eq '--version') {
245
0
0
        version();
246
0
0
       exit 0;
247    } else {
248
0
0
        usageerr(g_("unknown option '%s'"), $arg);
249    }
250}
251
252
3
3
my %v;
253
254# Initialize variables from environment and information to gather.
255
3
6
foreach my $k (keys %req_vars) {
256
99
50
33
88
    if (length $ENV{$k} && ! $force) {
257
0
0
        $v{$k} = $ENV{$k};
258
0
0
        delete $req_vars{$k};
259    } else {
260
99
54
        $req_info |= $req_vars{$k};
261    }
262}
263
264#
265# Set build variables
266#
267
268
3
50
6
$v{DEB_BUILD_ARCH} = get_raw_build_arch()
269    if (action_needs(INFO_BUILD_ARCH_NAME));
270($v{DEB_BUILD_ARCH_ABI}, $v{DEB_BUILD_ARCH_LIBC},
271 $v{DEB_BUILD_ARCH_OS}, $v{DEB_BUILD_ARCH_CPU}) = debarch_to_debtuple($v{DEB_BUILD_ARCH})
272
3
50
19
    if (action_needs(INFO_BUILD_ARCH_TUPLE));
273($v{DEB_BUILD_ARCH_BITS}, $v{DEB_BUILD_ARCH_ENDIAN}) = debarch_to_abiattrs($v{DEB_BUILD_ARCH})
274
3
50
3
    if (action_needs(INFO_BUILD_ARCH_ATTR));
275
276$v{DEB_BUILD_MULTIARCH} = debarch_to_multiarch($v{DEB_BUILD_ARCH})
277
3
50
4
    if (action_needs(INFO_BUILD_MULTIARCH));
278
279
3
50
6
if (action_needs(INFO_BUILD_GNU_TUPLE)) {
280
3
5
  $v{DEB_BUILD_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_BUILD_ARCH});
281
3
7
  ($v{DEB_BUILD_GNU_CPU}, $v{DEB_BUILD_GNU_SYSTEM}) = split(/-/, $v{DEB_BUILD_GNU_TYPE}, 2);
282}
283
284#
285# Set host variables
286#
287
288# First perform some sanity checks on the host arguments passed.
289
290
3
8
($req_host_arch, $req_host_gnu_type) = check_arch_coherency($req_host_arch, $req_host_gnu_type);
291
292# Proceed to compute the host variables if needed.
293
294
3
50
33
3
$v{DEB_HOST_ARCH} = $req_host_arch || get_raw_host_arch()
295    if (action_needs(INFO_HOST_ARCH_NAME));
296($v{DEB_HOST_ARCH_ABI}, $v{DEB_HOST_ARCH_LIBC},
297 $v{DEB_HOST_ARCH_OS}, $v{DEB_HOST_ARCH_CPU}) = debarch_to_debtuple($v{DEB_HOST_ARCH})
298
3
50
17
    if (action_needs(INFO_HOST_ARCH_TUPLE));
299($v{DEB_HOST_ARCH_BITS}, $v{DEB_HOST_ARCH_ENDIAN}) = debarch_to_abiattrs($v{DEB_HOST_ARCH})
300
3
50
6
    if (action_needs(INFO_HOST_ARCH_ATTR));
301
302$v{DEB_HOST_MULTIARCH} = debarch_to_multiarch($v{DEB_HOST_ARCH})
303
3
50
10
    if (action_needs(INFO_HOST_MULTIARCH));
304
305
3
50
4
if (action_needs(INFO_HOST_GNU_TUPLE)) {
306
3
50
4
    if ($req_host_gnu_type eq '') {
307
3
36
        $v{DEB_HOST_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_HOST_ARCH});
308    } else {
309
0
0
        $v{DEB_HOST_GNU_TYPE} = $req_host_gnu_type;
310    }
311
3
22
    ($v{DEB_HOST_GNU_CPU}, $v{DEB_HOST_GNU_SYSTEM}) = split(/-/, $v{DEB_HOST_GNU_TYPE}, 2);
312
313
3
4
    my $host_gnu_type = get_host_gnu_type();
314
315    warning(g_('specified GNU system type %s does not match CC system ' .
316               'type %s, try setting a correct CC environment variable'),
317            $v{DEB_HOST_GNU_TYPE}, $host_gnu_type)
318
3
50
33
10
        if ($host_gnu_type ne '') && ($host_gnu_type ne $v{DEB_HOST_GNU_TYPE});
319}
320
321#
322# Set target variables
323#
324
325# First perform some sanity checks on the target arguments passed.
326
327
3
7
($req_target_arch, $req_target_gnu_type) = check_arch_coherency($req_target_arch, $req_target_gnu_type);
328
329# Proceed to compute the target variables if needed.
330
331
3
50
33
3
$v{DEB_TARGET_ARCH} = $req_target_arch || $v{DEB_HOST_ARCH} || $req_host_arch || get_raw_host_arch()
332    if (action_needs(INFO_TARGET_ARCH_NAME));
333($v{DEB_TARGET_ARCH_ABI}, $v{DEB_TARGET_ARCH_LIBC},
334 $v{DEB_TARGET_ARCH_OS}, $v{DEB_TARGET_ARCH_CPU}) = debarch_to_debtuple($v{DEB_TARGET_ARCH})
335
3
50
30
    if (action_needs(INFO_TARGET_ARCH_TUPLE));
336($v{DEB_TARGET_ARCH_BITS}, $v{DEB_TARGET_ARCH_ENDIAN}) = debarch_to_abiattrs($v{DEB_TARGET_ARCH})
337
3
50
4
    if (action_needs(INFO_TARGET_ARCH_ATTR));
338
339$v{DEB_TARGET_MULTIARCH} = debarch_to_multiarch($v{DEB_TARGET_ARCH})
340
3
50
2
    if (action_needs(INFO_TARGET_MULTIARCH));
341
342
3
50
16
if (action_needs(INFO_TARGET_GNU_TUPLE)) {
343
3
50
3
    if ($req_target_gnu_type eq '') {
344
3
4
        $v{DEB_TARGET_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_TARGET_ARCH});
345    } else {
346
0
0
        $v{DEB_TARGET_GNU_TYPE} = $req_target_gnu_type;
347    }
348
3
5
    ($v{DEB_TARGET_GNU_CPU}, $v{DEB_TARGET_GNU_SYSTEM}) = split(/-/, $v{DEB_TARGET_GNU_TYPE}, 2);
349}
350
351
352
3
50
0
0
0
0
0
0
0
5
if ($action eq 'list') {
353
3
40
    foreach my $k (sort keys %arch_vars) {
354
99
71
        print "$k=$v{$k}\n";
355    }
356} elsif ($action eq 'print-set') {
357
0
0
0
0
    if ($print_format eq 'shell') {
358
0
0
        foreach my $k (sort keys %arch_vars) {
359
0
0
            print "$k=$v{$k}; ";
360        }
361
0
0
        print 'export ' . join(' ', sort keys %arch_vars) . "\n";
362    } elsif ($print_format eq 'make') {
363
0
0
        foreach my $k (sort keys %arch_vars) {
364
0
0
            print "export $k = $v{$k}\n";
365        }
366    }
367} elsif ($action eq 'print-unset') {
368
0
0
0
0
    if ($print_format eq 'shell') {
369
0
0
        print 'unset ' . join(' ', sort keys %arch_vars) . "\n";
370    } elsif ($print_format eq 'make') {
371
0
0
        foreach my $k (sort keys %arch_vars) {
372
0
0
            print "undefine $k\n";
373        }
374    }
375} elsif ($action eq 'equal') {
376
0
0
    exit !debarch_eq($v{DEB_HOST_ARCH}, $req_eq_arch);
377} elsif ($action eq 'is') {
378
0
0
    exit !debarch_is($v{DEB_HOST_ARCH}, $req_is_arch);
379} elsif ($action eq 'command') {
380
0
0
    @ENV{keys %v} = values %v;
381    ## no critic (TestingAndDebugging::ProhibitNoWarnings)
382
3
3
3
3
9
10
2432
    no warnings qw(exec);
383
0
0
0
    exec @ARGV or syserr(g_('unable to execute %s'), "@ARGV");
384} elsif ($action eq 'query') {
385
0
0
    print "$v{$req_variable_to_print}\n";
386} elsif ($action eq 'list-known') {
387
0
0
    foreach my $arch (get_valid_arches()) {
388
0
0
        my ($bits, $endian) = debarch_to_abiattrs($arch);
389
390
0
0
0
0
        next if $req_match_endian and $endian ne $req_match_endian;
391
0
0
0
0
        next if $req_match_bits and $bits ne $req_match_bits;
392
0
0
0
0
        next if $req_match_wildcard and not debarch_is($arch, $req_match_wildcard);
393
394
0
0
        print "$arch\n";
395    }
396}