scripts/dpkg-architecture.pl

   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 use strict;
  23 use warnings;
  24
  25 use Dpkg ();
  26 use Dpkg::Gettext;
  27 use Dpkg::Getopt;
  28 use Dpkg::ErrorHandling;
  29 use Dpkg::Arch qw(:getters :mappers debarch_eq debarch_is);
  30
  31 textdomain('dpkg-dev');
  32
  33 sub version {
  34     printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION;
  35
  36     printf g_('
  37 This is free software; see the GNU General Public License version 2 or
  38 later for copying conditions. There is NO warranty.
  39 ');
  40 }
  41
  42 sub usage {
  43     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
  76 sub check_arch_coherency
  77 {
  78     my ($arch, $gnu_type) = @_;
  79
  80     if ($arch ne '' && $gnu_type eq '') {
  81         $gnu_type = debarch_to_gnutriplet($arch);
  82         error(g_('unknown Debian architecture %s, you must specify ' .
  83                  'GNU system type, too'), $arch)
  84             unless defined $gnu_type;
  85     }
  86
  87     if ($gnu_type ne '' && $arch eq '') {
  88         $arch = gnutriplet_to_debarch($gnu_type);
  89         error(g_('unknown GNU system type %s, you must specify ' .
  90                  'Debian architecture, too'), $gnu_type)
  91             unless defined $arch;
  92     }
  93
  94     if ($gnu_type ne '' && $arch ne '') {
  95         my $dfl_gnu_type = debarch_to_gnutriplet($arch);
  96         error(g_('unknown default GNU system type for Debian architecture %s'),
  97               $arch)
  98             unless defined $dfl_gnu_type;
  99         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     return ($arch, $gnu_type);
 106 }
 107
 108 use constant {
 109     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 };
 127
 128 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 my %known_print_format = map { $_ => 1 } qw(shell make);
 165 my $print_format = 'shell';
 166
 167 my %req_vars = %arch_vars;
 168 my $req_info = 0;
 169 my $req_host_arch = '';
 170 my $req_host_gnu_type = '';
 171 my $req_target_arch = '';
 172 my $req_target_gnu_type = '';
 173 my $req_eq_arch = '';
 174 my $req_is_arch = '';
 175 my $req_match_wildcard = '';
 176 my $req_match_bits = '';
 177 my $req_match_endian = '';
 178 my $req_variable_to_print;
 179 my $action = 'list';
 180 my $force = 0;
 181
 182 sub action_needs($) {
 183     my $bits = shift;
 184     return (($req_info & $bits) == $bits);
 185 }
 186
 187 @ARGV = normalize_options(args => \@ARGV, delim => '-c');
 188
 189 while (@ARGV) {
 190     my $arg = shift;
 191
 192     if ($arg eq '-a' or $arg eq '--host-arch') {
 193         $req_host_arch = shift;
 194     } elsif ($arg eq '-t' or $arg eq '--host-type') {
 195         $req_host_gnu_type = shift;
 196     } elsif ($arg eq '-A' or $arg eq '--target-arch') {
 197         $req_target_arch = shift;
 198     } elsif ($arg eq '-T' or $arg eq '--target-type') {
 199         $req_target_gnu_type = shift;
 200     } elsif ($arg eq '-W' or $arg eq '--match-wildcard') {
 201         $req_match_wildcard = shift;
 202     } elsif ($arg eq '-B' or $arg eq '--match-bits') {
 203         $req_match_bits = shift;
 204     } elsif ($arg eq '-E' or $arg eq '--match-endian') {
 205         $req_match_endian = shift;
 206     } elsif ($arg eq '-e' or $arg eq '--equal') {
 207         $req_eq_arch = shift;
 208         %req_vars = %arch_vars{DEB_HOST_ARCH};
 209         $action = 'equal';
 210     } elsif ($arg eq '-i' or $arg eq '--is') {
 211         $req_is_arch = shift;
 212         %req_vars = %arch_vars{DEB_HOST_ARCH};
 213         $action = 'is';
 214     } elsif ($arg eq '-u' or $arg eq '--print-unset') {
 215         %req_vars = ();
 216         $action = 'print-unset';
 217     } elsif ($arg eq '-l' or $arg eq '--list') {
 218         $action = 'list';
 219     } elsif ($arg eq '-s' or $arg eq '--print-set') {
 220         %req_vars = %arch_vars;
 221         $action = 'print-set';
 222     } elsif ($arg eq '--print-format') {
 223         $print_format = shift;
 224         error(g_('%s is not a supported print format'), $print_format)
 225             unless exists $known_print_format{$print_format};
 226     } elsif ($arg eq '-f' or $arg eq '--force') {
 227         $force = 1;
 228     } elsif ($arg eq '-q' or $arg eq '--query') {
 229         my $varname = shift;
 230         error(g_('%s is not a supported variable name'), $varname)
 231             unless (exists $arch_vars{$varname});
 232         $req_variable_to_print = "$varname";
 233         %req_vars = %arch_vars{$varname};
 234         $action = 'query';
 235     } elsif ($arg eq '-c' or $arg eq '--command') {
 236         $action = 'command';
 237         last;
 238     } elsif ($arg eq '-L' or $arg eq '--list-known') {
 239         %req_vars = ();
 240         $action = 'list-known';
 241     } elsif ($arg eq '-?' or $arg eq '--help') {
 242         usage();
 243        exit 0;
 244     } elsif ($arg eq '--version') {
 245         version();
 246        exit 0;
 247     } else {
 248         usageerr(g_("unknown option '%s'"), $arg);
 249     }
 250 }
 251
 252 my %v;
 253
 254 # Initialize variables from environment and information to gather.
 255 foreach my $k (keys %req_vars) {
 256     if (length $ENV{$k} && ! $force) {
 257         $v{$k} = $ENV{$k};
 258         delete $req_vars{$k};
 259     } else {
 260         $req_info |= $req_vars{$k};
 261     }
 262 }
 263
 264 #
 265 # Set build variables
 266 #
 267
 268 $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     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     if (action_needs(INFO_BUILD_ARCH_ATTR));
 275
 276 $v{DEB_BUILD_MULTIARCH} = debarch_to_multiarch($v{DEB_BUILD_ARCH})
 277     if (action_needs(INFO_BUILD_MULTIARCH));
 278
 279 if (action_needs(INFO_BUILD_GNU_TUPLE)) {
 280   $v{DEB_BUILD_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_BUILD_ARCH});
 281   ($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 ($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 $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     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     if (action_needs(INFO_HOST_ARCH_ATTR));
 301
 302 $v{DEB_HOST_MULTIARCH} = debarch_to_multiarch($v{DEB_HOST_ARCH})
 303     if (action_needs(INFO_HOST_MULTIARCH));
 304
 305 if (action_needs(INFO_HOST_GNU_TUPLE)) {
 306     if ($req_host_gnu_type eq '') {
 307         $v{DEB_HOST_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_HOST_ARCH});
 308     } else {
 309         $v{DEB_HOST_GNU_TYPE} = $req_host_gnu_type;
 310     }
 311     ($v{DEB_HOST_GNU_CPU}, $v{DEB_HOST_GNU_SYSTEM}) = split(/-/, $v{DEB_HOST_GNU_TYPE}, 2);
 312
 313     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         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 ($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 $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     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     if (action_needs(INFO_TARGET_ARCH_ATTR));
 338
 339 $v{DEB_TARGET_MULTIARCH} = debarch_to_multiarch($v{DEB_TARGET_ARCH})
 340     if (action_needs(INFO_TARGET_MULTIARCH));
 341
 342 if (action_needs(INFO_TARGET_GNU_TUPLE)) {
 343     if ($req_target_gnu_type eq '') {
 344         $v{DEB_TARGET_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_TARGET_ARCH});
 345     } else {
 346         $v{DEB_TARGET_GNU_TYPE} = $req_target_gnu_type;
 347     }
 348     ($v{DEB_TARGET_GNU_CPU}, $v{DEB_TARGET_GNU_SYSTEM}) = split(/-/, $v{DEB_TARGET_GNU_TYPE}, 2);
 349 }
 350
 351
 352 if ($action eq 'list') {
 353     foreach my $k (sort keys %arch_vars) {
 354         print "$k=$v{$k}\n";
 355     }
 356 } elsif ($action eq 'print-set') {
 357     if ($print_format eq 'shell') {
 358         foreach my $k (sort keys %arch_vars) {
 359             print "$k=$v{$k}; ";
 360         }
 361         print 'export ' . join(' ', sort keys %arch_vars) . "\n";
 362     } elsif ($print_format eq 'make') {
 363         foreach my $k (sort keys %arch_vars) {
 364             print "export $k = $v{$k}\n";
 365         }
 366     }
 367 } elsif ($action eq 'print-unset') {
 368     if ($print_format eq 'shell') {
 369         print 'unset ' . join(' ', sort keys %arch_vars) . "\n";
 370     } elsif ($print_format eq 'make') {
 371         foreach my $k (sort keys %arch_vars) {
 372             print "undefine $k\n";
 373         }
 374     }
 375 } elsif ($action eq 'equal') {
 376     exit !debarch_eq($v{DEB_HOST_ARCH}, $req_eq_arch);
 377 } elsif ($action eq 'is') {
 378     exit !debarch_is($v{DEB_HOST_ARCH}, $req_is_arch);
 379 } elsif ($action eq 'command') {
 380     @ENV{keys %v} = values %v;
 381     ## no critic (TestingAndDebugging::ProhibitNoWarnings)
 382     no warnings qw(exec);
 383     exec @ARGV or syserr(g_('unable to execute %s'), "@ARGV");
 384 } elsif ($action eq 'query') {
 385     print "$v{$req_variable_to_print}\n";
 386 } elsif ($action eq 'list-known') {
 387     foreach my $arch (get_valid_arches()) {
 388         my ($bits, $endian) = debarch_to_abiattrs($arch);
 389
 390         next if $req_match_endian and $endian ne $req_match_endian;
 391         next if $req_match_bits and $bits ne $req_match_bits;
 392         next if $req_match_wildcard and not debarch_is($arch, $req_match_wildcard);
 393
 394         print "$arch\n";
 395     }
 396 }