diff options
Diffstat (limited to 'scripts/Dpkg/Arch.pm')
| -rw-r--r-- | scripts/Dpkg/Arch.pm | 709 |
1 files changed, 709 insertions, 0 deletions
diff --git a/scripts/Dpkg/Arch.pm b/scripts/Dpkg/Arch.pm new file mode 100644 index 0000000..14709d6 --- /dev/null +++ b/scripts/Dpkg/Arch.pm @@ -0,0 +1,709 @@ +# Copyright © 2006-2015 Guillem Jover <guillem@debian.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <https://www.gnu.org/licenses/>. + +package Dpkg::Arch; + +=encoding utf8 + +=head1 NAME + +Dpkg::Arch - handle architectures + +=head1 DESCRIPTION + +The Dpkg::Arch module provides functions to handle Debian architectures, +wildcards, and mapping from and to GNU triplets. + +No symbols are exported by default. The :all tag can be used to import all +symbols. The :getters, :parsers, :mappers and :operators tags can be used +to import specific symbol subsets. + +=cut + +use strict; +use warnings; +use feature qw(state); + +our $VERSION = '1.03'; +our @EXPORT_OK = qw( + get_raw_build_arch + get_raw_host_arch + get_build_arch + get_host_arch + get_host_gnu_type + get_valid_arches + debarch_eq + debarch_is + debarch_is_wildcard + debarch_is_illegal + debarch_is_concerned + debarch_to_abiattrs + debarch_to_cpubits + debarch_to_gnutriplet + debarch_to_debtuple + debarch_to_multiarch + debarch_list_parse + debtuple_to_debarch + debtuple_to_gnutriplet + gnutriplet_to_debarch + gnutriplet_to_debtuple + gnutriplet_to_multiarch +); +our %EXPORT_TAGS = ( + all => [ @EXPORT_OK ], + getters => [ qw( + get_raw_build_arch + get_raw_host_arch + get_build_arch + get_host_arch + get_host_gnu_type + get_valid_arches + ) ], + parsers => [ qw( + debarch_list_parse + ) ], + mappers => [ qw( + debarch_to_abiattrs + debarch_to_gnutriplet + debarch_to_debtuple + debarch_to_multiarch + debtuple_to_debarch + debtuple_to_gnutriplet + gnutriplet_to_debarch + gnutriplet_to_debtuple + gnutriplet_to_multiarch + ) ], + operators => [ qw( + debarch_eq + debarch_is + debarch_is_wildcard + debarch_is_illegal + debarch_is_concerned + ) ], +); + + +use Exporter qw(import); +use List::Util qw(any); + +use Dpkg (); +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Build::Env; + +my (@cpu, @os); +my (%cputable, %ostable); +my (%cputable_re, %ostable_re); +my (%cpubits, %cpuendian); +my %abibits; + +my %debtuple_to_debarch; +my %debarch_to_debtuple; + +=head1 FUNCTIONS + +=over 4 + +=item $arch = get_raw_build_arch() + +Get the raw build Debian architecture, without taking into account variables +from the environment. + +=cut + +sub get_raw_build_arch() +{ + state $build_arch; + + return $build_arch if defined $build_arch; + + # Note: We *always* require an installed dpkg when inferring the + # build architecture. The bootstrapping case is handled by + # dpkg-architecture itself, by avoiding computing the DEB_BUILD_ + # variables when they are not requested. + + ## no critic (TestingAndDebugging::ProhibitNoWarnings) + no warnings qw(exec); + $build_arch = qx(dpkg --print-architecture); + syserr('dpkg --print-architecture failed') if $? >> 8; + + chomp $build_arch; + return $build_arch; +} + +=item $arch = get_build_arch() + +Get the build Debian architecture, using DEB_BUILD_ARCH from the environment +if available. + +=cut + +sub get_build_arch() +{ + return Dpkg::Build::Env::get('DEB_BUILD_ARCH') || get_raw_build_arch(); +} + +{ + my %cc_host_gnu_type; + + sub get_host_gnu_type() + { + my $CC = $ENV{CC} || 'gcc'; + + return $cc_host_gnu_type{$CC} if defined $cc_host_gnu_type{$CC}; + + ## no critic (TestingAndDebugging::ProhibitNoWarnings) + no warnings qw(exec); + $cc_host_gnu_type{$CC} = qx($CC -dumpmachine); + if ($? >> 8) { + $cc_host_gnu_type{$CC} = ''; + } else { + chomp $cc_host_gnu_type{$CC}; + } + + return $cc_host_gnu_type{$CC}; + } + + sub set_host_gnu_type + { + my ($host_gnu_type) = @_; + my $CC = $ENV{CC} || 'gcc'; + + $cc_host_gnu_type{$CC} = $host_gnu_type; + } +} + +=item $arch = get_raw_host_arch() + +Get the raw host Debian architecture, without taking into account variables +from the environment. + +=cut + +sub get_raw_host_arch() +{ + state $host_arch; + + return $host_arch if defined $host_arch; + + my $host_gnu_type = get_host_gnu_type(); + + if ($host_gnu_type eq '') { + warning(g_('cannot determine CC system type, falling back to ' . + 'default (native compilation)')); + } else { + my (@host_archtuple) = gnutriplet_to_debtuple($host_gnu_type); + $host_arch = debtuple_to_debarch(@host_archtuple); + + if (defined $host_arch) { + $host_gnu_type = debtuple_to_gnutriplet(@host_archtuple); + } else { + warning(g_('unknown CC system type %s, falling back to ' . + 'default (native compilation)'), $host_gnu_type); + $host_gnu_type = ''; + } + set_host_gnu_type($host_gnu_type); + } + + if (!defined($host_arch)) { + # Switch to native compilation. + $host_arch = get_raw_build_arch(); + } + + return $host_arch; +} + +=item $arch = get_host_arch() + +Get the host Debian architecture, using DEB_HOST_ARCH from the environment +if available. + +=cut + +sub get_host_arch() +{ + return Dpkg::Build::Env::get('DEB_HOST_ARCH') || get_raw_host_arch(); +} + +=item @arch_list = get_valid_arches() + +Get an array with all currently known Debian architectures. + +=cut + +sub get_valid_arches() +{ + _load_cputable(); + _load_ostable(); + + my @arches; + + foreach my $os (@os) { + foreach my $cpu (@cpu) { + my $arch = debtuple_to_debarch(split(/-/, $os, 3), $cpu); + push @arches, $arch if defined($arch); + } + } + + return @arches; +} + +my %table_loaded; +sub _load_table +{ + my ($table, $loader) = @_; + + return if $table_loaded{$table}; + + local $_; + local $/ = "\n"; + + open my $table_fh, '<', "$Dpkg::DATADIR/$table" + or syserr(g_('cannot open %s'), $table); + while (<$table_fh>) { + $loader->($_); + } + close $table_fh; + + $table_loaded{$table} = 1; +} + +sub _load_cputable +{ + _load_table('cputable', sub { + if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) { + $cputable{$1} = $2; + $cputable_re{$1} = $3; + $cpubits{$1} = $4; + $cpuendian{$1} = $5; + push @cpu, $1; + } + }); +} + +sub _load_ostable +{ + _load_table('ostable', sub { + if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) { + $ostable{$1} = $2; + $ostable_re{$1} = $3; + push @os, $1; + } + }); +} + +sub _load_abitable() +{ + _load_table('abitable', sub { + if (m/^(?!\#)(\S+)\s+(\S+)/) { + $abibits{$1} = $2; + } + }); +} + +sub _load_tupletable() +{ + _load_cputable(); + + _load_table('tupletable', sub { + if (m/^(?!\#)(\S+)\s+(\S+)/) { + my $debtuple = $1; + my $debarch = $2; + + if ($debtuple =~ /<cpu>/) { + foreach my $_cpu (@cpu) { + (my $dt = $debtuple) =~ s/<cpu>/$_cpu/; + (my $da = $debarch) =~ s/<cpu>/$_cpu/; + + next if exists $debarch_to_debtuple{$da} + or exists $debtuple_to_debarch{$dt}; + + $debarch_to_debtuple{$da} = $dt; + $debtuple_to_debarch{$dt} = $da; + } + } else { + $debarch_to_debtuple{$2} = $1; + $debtuple_to_debarch{$1} = $2; + } + } + }); +} + +sub debtuple_to_gnutriplet(@) +{ + my ($abi, $libc, $os, $cpu) = @_; + + _load_cputable(); + _load_ostable(); + + return unless + defined $abi && defined $libc && defined $os && defined $cpu && + exists $cputable{$cpu} && exists $ostable{"$abi-$libc-$os"}; + return join('-', $cputable{$cpu}, $ostable{"$abi-$libc-$os"}); +} + +sub gnutriplet_to_debtuple($) +{ + my $gnu = shift; + return unless defined($gnu); + my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2); + return unless defined($gnu_cpu) && defined($gnu_os); + + _load_cputable(); + _load_ostable(); + + my ($os, $cpu); + + foreach my $_cpu (@cpu) { + if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) { + $cpu = $_cpu; + last; + } + } + + foreach my $_os (@os) { + if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) { + $os = $_os; + last; + } + } + + return if !defined($cpu) || !defined($os); + return (split(/-/, $os, 3), $cpu); +} + +=item $multiarch = gnutriplet_to_multiarch($gnutriplet) + +Map a GNU triplet into a Debian multiarch triplet. + +=cut + +sub gnutriplet_to_multiarch($) +{ + my $gnu = shift; + my ($cpu, $cdr) = split(/-/, $gnu, 2); + + if ($cpu =~ /^i[4567]86$/) { + return "i386-$cdr"; + } else { + return $gnu; + } +} + +=item $multiarch = debarch_to_multiarch($arch) + +Map a Debian architecture into a Debian multiarch triplet. + +=cut + +sub debarch_to_multiarch($) +{ + my $arch = shift; + + return gnutriplet_to_multiarch(debarch_to_gnutriplet($arch)); +} + +sub debtuple_to_debarch(@) +{ + my ($abi, $libc, $os, $cpu) = @_; + + _load_tupletable(); + + if (!defined $abi || !defined $libc || !defined $os || !defined $cpu) { + return; + } elsif (exists $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}) { + return $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}; + } else { + return; + } +} + +sub debarch_to_debtuple($) +{ + my $arch = shift; + + return if not defined $arch; + + _load_tupletable(); + + if ($arch =~ /^linux-([^-]*)/) { + # XXX: Might disappear in the future, not sure yet. + $arch = $1; + } + + my $tuple = $debarch_to_debtuple{$arch}; + + if (defined($tuple)) { + my @tuple = split /-/, $tuple, 4; + return @tuple if wantarray; + return { + abi => $tuple[0], + libc => $tuple[1], + os => $tuple[2], + cpu => $tuple[3], + }; + } else { + return; + } +} + +=item $gnutriplet = debarch_to_gnutriplet($arch) + +Map a Debian architecture into a GNU triplet. + +=cut + +sub debarch_to_gnutriplet($) +{ + my $arch = shift; + + return debtuple_to_gnutriplet(debarch_to_debtuple($arch)); +} + +=item $arch = gnutriplet_to_debarch($gnutriplet) + +Map a GNU triplet into a Debian architecture. + +=cut + +sub gnutriplet_to_debarch($) +{ + my $gnu = shift; + + return debtuple_to_debarch(gnutriplet_to_debtuple($gnu)); +} + +sub debwildcard_to_debtuple($) +{ + my $arch = shift; + my @tuple = split /-/, $arch, 4; + + if (any { $_ eq 'any' } @tuple) { + if (scalar @tuple == 4) { + return @tuple; + } elsif (scalar @tuple == 3) { + return ('any', @tuple); + } elsif (scalar @tuple == 2) { + return ('any', 'any', @tuple); + } else { + return ('any', 'any', 'any', 'any'); + } + } else { + return debarch_to_debtuple($arch); + } +} + +sub debarch_to_abiattrs($) +{ + my $arch = shift; + my ($abi, $libc, $os, $cpu) = debarch_to_debtuple($arch); + + if (defined($cpu)) { + _load_abitable(); + + return ($abibits{$abi} // $cpubits{$cpu}, $cpuendian{$cpu}); + } else { + return; + } +} + +sub debarch_to_cpubits($) +{ + my $arch = shift; + my (undef, undef, undef, $cpu) = debarch_to_debtuple($arch); + + if (defined $cpu) { + return $cpubits{$cpu}; + } else { + return; + } +} + +=item $bool = debarch_eq($arch_a, $arch_b) + +Evaluate the equality of a Debian architecture, by comparing with another +Debian architecture. No wildcard matching is performed. + +=cut + +sub debarch_eq($$) +{ + my ($a, $b) = @_; + + return 1 if ($a eq $b); + + my @a = debarch_to_debtuple($a); + my @b = debarch_to_debtuple($b); + + return 0 if scalar @a != 4 or scalar @b != 4; + + return $a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2] && $a[3] eq $b[3]; +} + +=item $bool = debarch_is($arch, $arch_wildcard) + +Evaluate the identity of a Debian architecture, by matching with an +architecture wildcard. + +=cut + +sub debarch_is($$) +{ + my ($real, $alias) = @_; + + return 1 if ($alias eq $real or $alias eq 'any'); + + my @real = debarch_to_debtuple($real); + my @alias = debwildcard_to_debtuple($alias); + + return 0 if scalar @real != 4 or scalar @alias != 4; + + if (($alias[0] eq $real[0] || $alias[0] eq 'any') && + ($alias[1] eq $real[1] || $alias[1] eq 'any') && + ($alias[2] eq $real[2] || $alias[2] eq 'any') && + ($alias[3] eq $real[3] || $alias[3] eq 'any')) { + return 1; + } + + return 0; +} + +=item $bool = debarch_is_wildcard($arch) + +Evaluate whether a Debian architecture is an architecture wildcard. + +=cut + +sub debarch_is_wildcard($) +{ + my $arch = shift; + + return 0 if $arch eq 'all'; + + my @tuple = debwildcard_to_debtuple($arch); + + return 0 if scalar @tuple != 4; + return 1 if any { $_ eq 'any' } @tuple; + return 0; +} + +=item $bool = debarch_is_illegal($arch, %options) + +Validate an architecture name. + +If the "positive" option is set to a true value, only positive architectures +will be accepted, otherwise negated architectures are allowed. + +=cut + +sub debarch_is_illegal +{ + my ($arch, %opts) = @_; + my $arch_re = qr/[a-zA-Z0-9][a-zA-Z0-9-]*/; + + if ($opts{positive}) { + return $arch !~ m/^$arch_re$/; + } else { + return $arch !~ m/^!?$arch_re$/; + } +} + +=item $bool = debarch_is_concerned($arch, @arches) + +Evaluate whether a Debian architecture applies to the list of architecture +restrictions, as usually found in dependencies inside square brackets. + +=cut + +sub debarch_is_concerned +{ + my ($host_arch, @arches) = @_; + + my $seen_arch = 0; + foreach my $arch (@arches) { + $arch = lc $arch; + + if ($arch =~ /^!/) { + my $not_arch = $arch; + $not_arch =~ s/^!//; + + if (debarch_is($host_arch, $not_arch)) { + $seen_arch = 0; + last; + } else { + # !arch includes by default all other arches + # unless they also appear in a !otherarch + $seen_arch = 1; + } + } elsif (debarch_is($host_arch, $arch)) { + $seen_arch = 1; + last; + } + } + return $seen_arch; +} + +=item @array = debarch_list_parse($arch_list, %options) + +Parse an architecture list. + +If the "positive" option is set to a true value, only positive architectures +will be accepted, otherwise negated architectures are allowed. + +=cut + +sub debarch_list_parse +{ + my ($arch_list, %opts) = @_; + my @arch_list = split ' ', $arch_list; + + foreach my $arch (@arch_list) { + if (debarch_is_illegal($arch, %opts)) { + error(g_("'%s' is not a legal architecture in list '%s'"), + $arch, $arch_list); + } + } + + return @arch_list; +} + +1; + +__END__ + +=back + +=head1 CHANGES + +=head2 Version 1.03 (dpkg 1.19.1) + +New argument: Accept a "positive" option in debarch_is_illegal() and +debarch_list_parse(). + +=head2 Version 1.02 (dpkg 1.18.19) + +New import tags: ":all", ":getters", ":parsers", ":mappers", ":operators". + +=head2 Version 1.01 (dpkg 1.18.5) + +New functions: debarch_is_illegal(), debarch_list_parse(). + +=head2 Version 1.00 (dpkg 1.18.2) + +Mark the module as public. + +=head1 SEE ALSO + +dpkg-architecture(1). |