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