scripts/Dpkg/Arch.pm

   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 =head1 NAME
  19
  20 Dpkg::Arch - handle architectures
  21
  22 =head1 DESCRIPTION
  23
  24 The Dpkg::Arch module provides functions to handle Debian architectures,
  25 wildcards, and mapping from and to GNU triplets.
  26
  27 No symbols are exported by default. The :all tag can be used to import all
  28 symbols. The :getters, :parsers, :mappers and :operators tags can be used
  29 to import specific symbol subsets.
  30
  31 =cut
  32
  33 package Dpkg::Arch 1.03;
  34
  35 use strict;
  36 use warnings;
  37 use feature qw(state);
  38
  39 our @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 );
  63 our %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 use Exporter qw(import);
  98 use List::Util qw(any);
  99
 100 use Dpkg ();
 101 use Dpkg::Gettext;
 102 use Dpkg::ErrorHandling;
 103 use Dpkg::BuildEnv;
 104
 105 my (@cpu, @os);
 106 my (%cputable, %ostable);
 107 my (%cputable_re, %ostable_re);
 108 my (%cpubits, %cpuendian);
 109 my %abibits;
 110
 111 my %debtuple_to_debarch;
 112 my %debarch_to_debtuple;
 113
 114 =head1 FUNCTIONS
 115
 116 =over 4
 117
 118 =item $arch = get_raw_build_arch()
 119
 120 Get the raw build Debian architecture, without taking into account variables
 121 from the environment.
 122
 123 =cut
 124
 125 sub get_raw_build_arch()
 126 {
 127     state $build_arch;
 128
 129     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     no warnings qw(exec);
 138     $build_arch = qx(dpkg --print-architecture);
 139     syserr('dpkg --print-architecture failed') if $? >> 8;
 140
 141     chomp $build_arch;
 142     return $build_arch;
 143 }
 144
 145 =item $arch = get_build_arch()
 146
 147 Get the build Debian architecture, using DEB_BUILD_ARCH from the environment
 148 if available.
 149
 150 =cut
 151
 152 sub get_build_arch()
 153 {
 154     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         my $CC = $ENV{CC} || 'gcc';
 163
 164         return $cc_host_gnu_type{$CC} if defined $cc_host_gnu_type{$CC};
 165
 166         ## no critic (TestingAndDebugging::ProhibitNoWarnings)
 167         no warnings qw(exec);
 168         $cc_host_gnu_type{$CC} = qx($CC -dumpmachine);
 169         if ($? >> 8) {
 170             $cc_host_gnu_type{$CC} = '';
 171         } else {
 172             chomp $cc_host_gnu_type{$CC};
 173         }
 174
 175         return $cc_host_gnu_type{$CC};
 176     }
 177
 178     sub set_host_gnu_type
 179     {
 180         my ($host_gnu_type) = @_;
 181         my $CC = $ENV{CC} || 'gcc';
 182
 183         $cc_host_gnu_type{$CC} = $host_gnu_type;
 184     }
 185 }
 186
 187 =item $arch = get_raw_host_arch()
 188
 189 Get the raw host Debian architecture, without taking into account variables
 190 from the environment.
 191
 192 =cut
 193
 194 sub get_raw_host_arch()
 195 {
 196     state $host_arch;
 197
 198     return $host_arch if defined $host_arch;
 199
 200     my $host_gnu_type = get_host_gnu_type();
 201
 202     if ($host_gnu_type eq '') {
 203         warning(g_('cannot determine CC system type, falling back to ' .
 204                    'default (native compilation)'));
 205     } else {
 206         my (@host_archtuple) = gnutriplet_to_debtuple($host_gnu_type);
 207         $host_arch = debtuple_to_debarch(@host_archtuple);
 208
 209         if (defined $host_arch) {
 210             $host_gnu_type = debtuple_to_gnutriplet(@host_archtuple);
 211         } else {
 212             warning(g_('unknown CC system type %s, falling back to ' .
 213                        'default (native compilation)'), $host_gnu_type);
 214             $host_gnu_type = '';
 215         }
 216         set_host_gnu_type($host_gnu_type);
 217     }
 218
 219     if (!defined($host_arch)) {
 220         # Switch to native compilation.
 221         $host_arch = get_raw_build_arch();
 222     }
 223
 224     return $host_arch;
 225 }
 226
 227 =item $arch = get_host_arch()
 228
 229 Get the host Debian architecture, using DEB_HOST_ARCH from the environment
 230 if available.
 231
 232 =cut
 233
 234 sub get_host_arch()
 235 {
 236     return Dpkg::BuildEnv::get('DEB_HOST_ARCH') || get_raw_host_arch();
 237 }
 238
 239 =item @arch_list = get_valid_arches()
 240
 241 Get an array with all currently known Debian architectures.
 242
 243 =cut
 244
 245 sub get_valid_arches()
 246 {
 247     _load_cputable();
 248     _load_ostable();
 249
 250     my @arches;
 251
 252     foreach my $os (@os) {
 253         foreach my $cpu (@cpu) {
 254             my $arch = debtuple_to_debarch(split(/-/, $os, 3), $cpu);
 255             push @arches, $arch if defined($arch);
 256         }
 257     }
 258
 259     return @arches;
 260 }
 261
 262 my %table_loaded;
 263 sub _load_table
 264 {
 265     my ($table, $loader) = @_;
 266
 267     return if $table_loaded{$table};
 268
 269     local $_;
 270     local $/ = "\n";
 271
 272     open my $table_fh, '<', "$Dpkg::DATADIR/$table"
 273         or syserr(g_('cannot open %s'), $table);
 274     while (<$table_fh>) {
 275         $loader->($_);
 276     }
 277     close $table_fh;
 278
 279     $table_loaded{$table} = 1;
 280 }
 281
 282 sub _load_cputable
 283 {
 284     _load_table('cputable', sub {
 285         if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) {
 286             $cputable{$1} = $2;
 287             $cputable_re{$1} = $3;
 288             $cpubits{$1} = $4;
 289             $cpuendian{$1} = $5;
 290             push @cpu, $1;
 291         }
 292     });
 293 }
 294
 295 sub _load_ostable
 296 {
 297     _load_table('ostable', sub {
 298         if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) {
 299             $ostable{$1} = $2;
 300             $ostable_re{$1} = $3;
 301             push @os, $1;
 302         }
 303     });
 304 }
 305
 306 sub _load_abitable()
 307 {
 308     _load_table('abitable', sub {
 309         if (m/^(?!\#)(\S+)\s+(\S+)/) {
 310             $abibits{$1} = $2;
 311         }
 312     });
 313 }
 314
 315 sub _load_tupletable()
 316 {
 317     _load_cputable();
 318
 319     _load_table('tupletable', sub {
 320         if (m/^(?!\#)(\S+)\s+(\S+)/) {
 321             my $debtuple = $1;
 322             my $debarch = $2;
 323
 324             if ($debtuple =~ /<cpu>/) {
 325                 foreach my $_cpu (@cpu) {
 326                     (my $dt = $debtuple) =~ s/<cpu>/$_cpu/;
 327                     (my $da = $debarch) =~ s/<cpu>/$_cpu/;
 328
 329                     next if exists $debarch_to_debtuple{$da}
 330                          or exists $debtuple_to_debarch{$dt};
 331
 332                     $debarch_to_debtuple{$da} = $dt;
 333                     $debtuple_to_debarch{$dt} = $da;
 334                 }
 335             } else {
 336                 $debarch_to_debtuple{$2} = $1;
 337                 $debtuple_to_debarch{$1} = $2;
 338             }
 339         }
 340     });
 341 }
 342
 343 sub debtuple_to_gnutriplet(@)
 344 {
 345     my ($abi, $libc, $os, $cpu) = @_;
 346
 347     _load_cputable();
 348     _load_ostable();
 349
 350     return unless
 351         defined $abi && defined $libc && defined $os && defined $cpu &&
 352         exists $cputable{$cpu} && exists $ostable{"$abi-$libc-$os"};
 353     return join('-', $cputable{$cpu}, $ostable{"$abi-$libc-$os"});
 354 }
 355
 356 sub gnutriplet_to_debtuple($)
 357 {
 358     my $gnu = shift;
 359     return unless defined($gnu);
 360     my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2);
 361     return unless defined($gnu_cpu) && defined($gnu_os);
 362
 363     _load_cputable();
 364     _load_ostable();
 365
 366     my ($os, $cpu);
 367
 368     foreach my $_cpu (@cpu) {
 369         if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) {
 370             $cpu = $_cpu;
 371             last;
 372         }
 373     }
 374
 375     foreach my $_os (@os) {
 376         if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) {
 377             $os = $_os;
 378             last;
 379         }
 380     }
 381
 382     return if !defined($cpu) || !defined($os);
 383     return (split(/-/, $os, 3), $cpu);
 384 }
 385
 386 =item $multiarch = gnutriplet_to_multiarch($gnutriplet)
 387
 388 Map a GNU triplet into a Debian multiarch triplet.
 389
 390 =cut
 391
 392 sub gnutriplet_to_multiarch($)
 393 {
 394     my $gnu = shift;
 395     my ($cpu, $cdr) = split(/-/, $gnu, 2);
 396
 397     if ($cpu =~ /^i[4567]86$/) {
 398         return "i386-$cdr";
 399     } else {
 400         return $gnu;
 401     }
 402 }
 403
 404 =item $multiarch = debarch_to_multiarch($arch)
 405
 406 Map a Debian architecture into a Debian multiarch triplet.
 407
 408 =cut
 409
 410 sub debarch_to_multiarch($)
 411 {
 412     my $arch = shift;
 413
 414     return gnutriplet_to_multiarch(debarch_to_gnutriplet($arch));
 415 }
 416
 417 sub debtuple_to_debarch(@)
 418 {
 419     my ($abi, $libc, $os, $cpu) = @_;
 420
 421     _load_tupletable();
 422
 423     if (!defined $abi || !defined $libc || !defined $os || !defined $cpu) {
 424         return;
 425     } elsif (exists $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}) {
 426         return $debtuple_to_debarch{"$abi-$libc-$os-$cpu"};
 427     } else {
 428         return;
 429     }
 430 }
 431
 432 sub debarch_to_debtuple($)
 433 {
 434     my $arch = shift;
 435
 436     return if not defined $arch;
 437
 438     _load_tupletable();
 439
 440     if ($arch =~ /^linux-([^-]*)/) {
 441         # XXX: Might disappear in the future, not sure yet.
 442         $arch = $1;
 443     }
 444
 445     my $tuple = $debarch_to_debtuple{$arch};
 446
 447     if (defined($tuple)) {
 448         my @tuple = split /-/, $tuple, 4;
 449         return @tuple if wantarray;
 450         return {
 451             abi => $tuple[0],
 452             libc => $tuple[1],
 453             os => $tuple[2],
 454             cpu => $tuple[3],
 455         };
 456     } else {
 457         return;
 458     }
 459 }
 460
 461 =item $gnutriplet = debarch_to_gnutriplet($arch)
 462
 463 Map a Debian architecture into a GNU triplet.
 464
 465 =cut
 466
 467 sub debarch_to_gnutriplet($)
 468 {
 469     my $arch = shift;
 470
 471     return debtuple_to_gnutriplet(debarch_to_debtuple($arch));
 472 }
 473
 474 =item $arch = gnutriplet_to_debarch($gnutriplet)
 475
 476 Map a GNU triplet into a Debian architecture.
 477
 478 =cut
 479
 480 sub gnutriplet_to_debarch($)
 481 {
 482     my $gnu = shift;
 483
 484     return debtuple_to_debarch(gnutriplet_to_debtuple($gnu));
 485 }
 486
 487 sub debwildcard_to_debtuple($)
 488 {
 489     my $arch = shift;
 490     my @tuple = split /-/, $arch, 4;
 491
 492     if (any { $_ eq 'any' } @tuple) {
 493         if (scalar @tuple == 4) {
 494             return @tuple;
 495         } elsif (scalar @tuple == 3) {
 496             return ('any', @tuple);
 497         } elsif (scalar @tuple == 2) {
 498             return ('any', 'any', @tuple);
 499         } else {
 500             return ('any', 'any', 'any', 'any');
 501         }
 502     } else {
 503         return debarch_to_debtuple($arch);
 504     }
 505 }
 506
 507 sub debarch_to_abiattrs($)
 508 {
 509     my $arch = shift;
 510     my ($abi, $libc, $os, $cpu) = debarch_to_debtuple($arch);
 511
 512     if (defined($cpu)) {
 513         _load_abitable();
 514
 515         return ($abibits{$abi} // $cpubits{$cpu}, $cpuendian{$cpu});
 516     } else {
 517         return;
 518     }
 519 }
 520
 521 sub debarch_to_cpubits($)
 522 {
 523     my $arch = shift;
 524     my $cpu;
 525
 526     ((undef) x 3, $cpu) = debarch_to_debtuple($arch);
 527
 528     if (defined $cpu) {
 529         return $cpubits{$cpu};
 530     } else {
 531         return;
 532     }
 533 }
 534
 535 =item $bool = debarch_eq($arch_a, $arch_b)
 536
 537 Evaluate the equality of a Debian architecture, by comparing with another
 538 Debian architecture. No wildcard matching is performed.
 539
 540 =cut
 541
 542 sub debarch_eq($$)
 543 {
 544     my ($a, $b) = @_;
 545
 546     return 1 if ($a eq $b);
 547
 548     my @a = debarch_to_debtuple($a);
 549     my @b = debarch_to_debtuple($b);
 550
 551     return 0 if scalar @a != 4 or scalar @b != 4;
 552
 553     return $a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2] && $a[3] eq $b[3];
 554 }
 555
 556 =item $bool = debarch_is($arch, $arch_wildcard)
 557
 558 Evaluate the identity of a Debian architecture, by matching with an
 559 architecture wildcard.
 560
 561 =cut
 562
 563 sub debarch_is($$)
 564 {
 565     my ($real, $alias) = @_;
 566
 567     return 1 if ($alias eq $real or $alias eq 'any');
 568
 569     my @real = debarch_to_debtuple($real);
 570     my @alias = debwildcard_to_debtuple($alias);
 571
 572     return 0 if scalar @real != 4 or scalar @alias != 4;
 573
 574     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         return 1;
 579     }
 580
 581     return 0;
 582 }
 583
 584 =item $bool = debarch_is_wildcard($arch)
 585
 586 Evaluate whether a Debian architecture is an architecture wildcard.
 587
 588 =cut
 589
 590 sub debarch_is_wildcard($)
 591 {
 592     my $arch = shift;
 593
 594     return 0 if $arch eq 'all';
 595
 596     my @tuple = debwildcard_to_debtuple($arch);
 597
 598     return 0 if scalar @tuple != 4;
 599     return 1 if any { $_ eq 'any' } @tuple;
 600     return 0;
 601 }
 602
 603 =item $bool = debarch_is_illegal($arch, %options)
 604
 605 Validate an architecture name.
 606
 607 If the "positive" option is set to a true value, only positive architectures
 608 will be accepted, otherwise negated architectures are allowed.
 609
 610 =cut
 611
 612 sub debarch_is_illegal
 613 {
 614     my ($arch, %opts) = @_;
 615     my $arch_re = qr/[a-zA-Z0-9][a-zA-Z0-9-]*/;
 616
 617     if ($opts{positive}) {
 618         return $arch !~ m/^$arch_re$/;
 619     } else {
 620         return $arch !~ m/^!?$arch_re$/;
 621     }
 622 }
 623
 624 =item $bool = debarch_is_concerned($arch, @arches)
 625
 626 Evaluate whether a Debian architecture applies to the list of architecture
 627 restrictions, as usually found in dependencies inside square brackets.
 628
 629 =cut
 630
 631 sub debarch_is_concerned
 632 {
 633     my ($host_arch, @arches) = @_;
 634
 635     my $seen_arch = 0;
 636     foreach my $arch (@arches) {
 637         $arch = lc $arch;
 638
 639         if ($arch =~ /^!/) {
 640             my $not_arch = $arch;
 641             $not_arch =~ s/^!//;
 642
 643             if (debarch_is($host_arch, $not_arch)) {
 644                 $seen_arch = 0;
 645                 last;
 646             } else {
 647                 # !arch includes by default all other arches
 648                 # unless they also appear in a !otherarch
 649                 $seen_arch = 1;
 650             }
 651         } elsif (debarch_is($host_arch, $arch)) {
 652             $seen_arch = 1;
 653             last;
 654         }
 655     }
 656     return $seen_arch;
 657 }
 658
 659 =item @array = debarch_list_parse($arch_list, %options)
 660
 661 Parse an architecture list.
 662
 663 If the "positive" option is set to a true value, only positive architectures
 664 will be accepted, otherwise negated architectures are allowed.
 665
 666 =cut
 667
 668 sub debarch_list_parse
 669 {
 670     my ($arch_list, %opts) = @_;
 671     my @arch_list = split ' ', $arch_list;
 672
 673     foreach my $arch (@arch_list) {
 674         if (debarch_is_illegal($arch, %opts)) {
 675             error(g_("'%s' is not a legal architecture in list '%s'"),
 676                   $arch, $arch_list);
 677         }
 678     }
 679
 680     return @arch_list;
 681 }
 682
 683 1;
 684
 685 =back
 686
 687 =head1 CHANGES
 688
 689 =head2 Version 1.03 (dpkg 1.19.1)
 690
 691 New argument: Accept a "positive" option in debarch_is_illegal() and
 692 debarch_list_parse().
 693
 694 =head2 Version 1.02 (dpkg 1.18.19)
 695
 696 New import tags: ":all", ":getters", ":parsers", ":mappers", ":operators".
 697
 698 =head2 Version 1.01 (dpkg 1.18.5)
 699
 700 New functions: debarch_is_illegal(), debarch_list_parse().
 701
 702 =head2 Version 1.00 (dpkg 1.18.2)
 703
 704 Mark the module as public.
 705
 706 =head1 SEE ALSO
 707
 708 L<dpkg-architecture(1)>.