summaryrefslogtreecommitdiffstats
path: root/lib/Lintian/Data/Architectures.pm
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Lintian/Data/Architectures.pm441
1 files changed, 441 insertions, 0 deletions
diff --git a/lib/Lintian/Data/Architectures.pm b/lib/Lintian/Data/Architectures.pm
new file mode 100644
index 0000000..c45ced4
--- /dev/null
+++ b/lib/Lintian/Data/Architectures.pm
@@ -0,0 +1,441 @@
+# -*- perl -*-
+
+# Copyright (C) 2011-2012 Niels Thykier <niels@thykier.net>
+# - Based on a shell script by Raphael Geissert <atomo64@gmail.com>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# 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 <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Architectures;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(first_value);
+use Unicode::UTF8 qw(decode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+
+const my $HOST_VARIABLES => q{host_variables};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::PreambledJSON';
+
+=encoding utf-8
+
+=head1 NAME
+
+Lintian::Data::Architectures -- Lintian API for handling architectures and wildcards
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Architectures;
+
+=head1 DESCRIPTION
+
+Lintian API for checking and expanding architectures and architecture
+wildcards. The functions are backed by a L<data|Lintian::Data> file,
+so it may be out of date (use private/refresh-archs to update it).
+
+Generally all architecture names are in the format "$os-$architecture" and
+wildcards are "$os-any" or "any-$cpu", though there are exceptions:
+
+Note that the architecture and cpu name are not always identical
+(example architecture "armhf" has cpu name "arm").
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item host_variables
+
+=item C<wildcards>
+
+=item C<names>
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'DEB_HOST_* Variables from Dpkg'
+);
+
+has location => (
+ is => 'rw',
+ default => 'architectures/host.json'
+);
+
+has host_variables => (
+ is => 'rw',
+ default => sub { {} },
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); }
+);
+
+has deb_host_multiarch => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub {
+ my ($self) = @_;
+
+ my %deb_host_multiarch;
+
+ $deb_host_multiarch{$_}
+ = $self->host_variables->{$_}{DEB_HOST_MULTIARCH}
+ for keys %{$self->host_variables};
+
+ return \%deb_host_multiarch;
+ }
+);
+
+# The list of directories searched by default by the dynamic linker.
+# Packages installing shared libraries into these directories must call
+# ldconfig, must have shlibs files, and must ensure those libraries have
+# proper SONAMEs.
+#
+# Directories listed here must not have leading slashes.
+#
+# On the topic of multi-arch dirs. Hopefully including the ones not
+# native to the local platform won't hurt.
+#
+# See Bug#469301 and Bug#464796 for more details.
+#
+has ldconfig_folders => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // {}); },
+ default => sub {
+ my ($self) = @_;
+
+ my @multiarch = values %{$self->deb_host_multiarch};
+ my @ldconfig_folders = map { ("lib/$_", "usr/lib/$_") } @multiarch;
+
+ my @always = qw{
+ lib
+ lib32
+ lib64
+ libx32
+ usr/lib
+ usr/lib32
+ usr/lib64
+ usr/libx32
+ usr/local/lib
+ };
+ push(@ldconfig_folders, @always);
+
+ my @with_slash = map { $_ . $SLASH } @ldconfig_folders;
+
+ return \@with_slash;
+ }
+);
+
+# Valid architecture wildcards.
+has wildcards => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub {
+ my ($self) = @_;
+
+ my %wildcards;
+
+ for my $hyphenated (keys %{$self->host_variables}) {
+
+ my $variables = $self->host_variables->{$hyphenated};
+
+ # NB: "$os-$cpu" is not always equal to $hyphenated
+ my $abi = $variables->{DEB_HOST_ARCH_ABI};
+ my $libc = $variables->{DEB_HOST_ARCH_LIBC};
+ my $os = $variables->{DEB_HOST_ARCH_OS};
+ my $cpu = $variables->{DEB_HOST_ARCH_CPU};
+
+ # map $os-any (e.g. "linux-any") and any-$architecture (e.g. "any-amd64") to
+ # the relevant architectures.
+ $wildcards{'any'}{$hyphenated} = 1;
+
+ $wildcards{'any-any'}{$hyphenated} = 1;
+ $wildcards{"any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$os-any"}{$hyphenated} = 1;
+
+ $wildcards{'any-any-any'}{$hyphenated} = 1;
+ $wildcards{"any-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"any-$os-any"}{$hyphenated} = 1;
+ $wildcards{"any-$os-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$libc-any-any"}{$hyphenated} = 1;
+ $wildcards{"$libc-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$libc-$os-any"}{$hyphenated} = 1;
+
+ $wildcards{'any-any-any-any'}{$hyphenated} = 1;
+ $wildcards{"any-any-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"any-any-$os-any"}{$hyphenated} = 1;
+ $wildcards{"any-any-$os-$cpu"}{$hyphenated} = 1;
+ $wildcards{"any-$libc-any-any"}{$hyphenated} = 1;
+ $wildcards{"any-$libc-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"any-$libc-$os-any"}{$hyphenated} = 1;
+ $wildcards{"any-$libc-$os-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$abi-any-any-any"}{$hyphenated} = 1;
+ $wildcards{"$abi-any-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$abi-any-$os-any"}{$hyphenated} = 1;
+ $wildcards{"$abi-any-$os-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$abi-$libc-any-any"}{$hyphenated} = 1;
+ $wildcards{"$abi-$libc-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$abi-$libc-$os-any"}{$hyphenated} = 1;
+ }
+
+ return \%wildcards;
+ }
+);
+
+# Maps aliases to the "original" arch name.
+# (e.g. "linux-amd64" => "amd64")
+has names => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub {
+ my ($self) = @_;
+
+ my %names;
+
+ for my $hyphenated (keys %{$self->host_variables}) {
+
+ my $variables = $self->host_variables->{$hyphenated};
+
+ $names{$hyphenated} = $hyphenated;
+
+ # NB: "$os-$cpu" ne $hyphenated in some cases
+ my $os = $variables->{DEB_HOST_ARCH_OS};
+ my $cpu = $variables->{DEB_HOST_ARCH_CPU};
+
+ if ($os eq 'linux') {
+
+ # Per Policy section 11.1 (3.9.3):
+ #
+ #"""[architecture] strings are in the format "os-arch", though
+ # the OS part is sometimes elided, as when the OS is Linux."""
+ #
+ # i.e. "linux-amd64" and "amd64" are aliases, so handle them
+ # as such. Currently, dpkg-architecture -L gives us "amd64"
+ # but in case it changes to "linux-amd64", we are prepared.
+
+ if ($hyphenated =~ /^linux-/) {
+ # It may be temping to use $cpu here, but it does not work
+ # for (e.g.) arm based architectures. Instead extract the
+ # "short" architecture name from $hyphenated
+ my (undef, $short) = split(/-/, $hyphenated, 2);
+ $names{$short} = $hyphenated;
+
+ } else {
+ # short string in $hyphenated
+ my $long = "$os-$hyphenated";
+ $names{$long} = $hyphenated;
+ }
+ }
+ }
+
+ return \%names;
+ }
+);
+
+=item is_wildcard ($wildcard)
+
+Returns a truth value if $wildcard is a known architecture wildcard.
+
+Note: 'any' is considered a wildcard and not an architecture.
+
+=cut
+
+sub is_wildcard {
+ my ($self, $wildcard) = @_;
+
+ return exists $self->wildcards->{$wildcard};
+}
+
+=item is_release_architecture ($architecture)
+
+Returns a truth value if $architecture is (an alias of) a Debian machine
+architecture. It returns a false value for
+architecture wildcards (including "any") and unknown architectures.
+
+=cut
+
+sub is_release_architecture {
+ my ($self, $architecture) = @_;
+
+ return exists $self->names->{$architecture};
+}
+
+=item expand_wildcard ($wildcard)
+
+Returns a list of architectures that this wildcard expands to. No
+order is guaranteed (even between calls). Returned values must not be
+modified.
+
+Note: This list is based on the architectures in Lintian's data file.
+However, many of these are not supported or used in Debian or any of
+its derivatives.
+
+The returned values matches the list generated by dpkg-architecture -L,
+so the returned list may use (e.g.) "amd64" for "linux-amd64".
+
+=cut
+
+sub expand_wildcard {
+ my ($self, $wildcard) = @_;
+
+ return keys %{ $self->wildcards->{$wildcard} // {} };
+}
+
+=item wildcard_includes ($wildcard, $architecture)
+
+Returns a truth value if $architecture is included in the list of
+architectures that $wildcard expands to.
+
+This is generally faster than
+
+ grep { $_ eq $architecture } expand_arch_wildcard ($wildcard)
+
+It also properly handles cases like "linux-amd64" and "amd64" being
+aliases.
+
+=cut
+
+sub wildcard_includes {
+ my ($self, $wildcard, $architecture) = @_;
+
+ $architecture = $self->names->{$architecture}
+ if exists $self->names->{$architecture};
+
+ return exists $self->wildcards->{$wildcard}{$architecture};
+}
+
+=item valid_restriction
+
+=cut
+
+sub valid_restriction {
+ my ($self, $restriction) = @_;
+
+ # strip any negative prefix
+ $restriction =~ s/^!//;
+
+ return
+ $self->is_release_architecture($restriction)
+ || $self->is_wildcard($restriction)
+ || $restriction eq 'all';
+}
+
+=item restriction_matches
+
+=cut
+
+sub restriction_matches {
+ my ($self, $restriction, $architecture) = @_;
+
+ # look for negative prefix and strip
+ my $match_wanted = !($restriction =~ s/^!//);
+
+ return $match_wanted
+ if $restriction eq $architecture;
+
+ return $match_wanted
+ if $self->is_wildcard($restriction)
+ && $self->wildcard_includes($restriction, $architecture);
+
+ return !$match_wanted;
+}
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ my $host_variables;
+
+ return 0
+ unless $self->read_file($path, \$host_variables);
+
+ $self->host_variables($host_variables);
+
+ return 1;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ local $ENV{LC_ALL} = 'C';
+ delete local $ENV{DEB_HOST_ARCH};
+
+ my @architectures
+ = split(/\n/, decode_utf8(safe_qx(qw{dpkg-architecture --list-known})));
+ chomp for @architectures;
+
+ my %host_variables;
+ for my $architecture (@architectures) {
+
+ my @lines= split(
+ /\n/,
+ decode_utf8(
+ safe_qx(qw{dpkg-architecture --host-arch}, $architecture)
+ )
+ );
+
+ for my $line (@lines) {
+ my ($key, $value) = split(/=/, $line, 2);
+
+ $host_variables{$architecture}{$key} = $value
+ if $key =~ /^DEB_HOST_/;
+ }
+ }
+
+ $self->cargo('host_variables');
+
+ my $data_path = "$basedir/" . $self->location;
+ my $status
+ = $self->write_file($HOST_VARIABLES, \%host_variables, $data_path);
+
+ return $status;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-04 07:48:13 +0000