diff options
author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-15 18:35:28 +0000 |
---|---|---|
committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-15 18:35:28 +0000 |
commit | ea314d2f45c40a006c0104157013ab4b857f665f (patch) | |
tree | 3ef2971cb3675c318b8d9effd987854ad3f6d3e8 /scripts/Dpkg | |
parent | Initial commit. (diff) | |
download | dpkg-ea314d2f45c40a006c0104157013ab4b857f665f.tar.xz dpkg-ea314d2f45c40a006c0104157013ab4b857f665f.zip |
Adding upstream version 1.22.4.upstream/1.22.4
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to '')
85 files changed, 25433 insertions, 0 deletions
diff --git a/scripts/Dpkg.pm b/scripts/Dpkg.pm new file mode 100644 index 0000000..8c567a4 --- /dev/null +++ b/scripts/Dpkg.pm @@ -0,0 +1,306 @@ +# 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg - module with core variables + +=head1 DESCRIPTION + +The Dpkg module provides a set of variables with information concerning +this system installation. + +It is also the entry point to the Dpkg module hierarchy. + +=cut + +package Dpkg 2.00; + +use strict; +use warnings; + +our @EXPORT_OK = qw( + $PROGNAME + $PROGVERSION + $PROGMAKE + $PROGTAR + $PROGPATCH + $CONFDIR + $ADMINDIR + $LIBDIR + $DATADIR +); + +use Exporter qw(import); + +=head1 VARIABLES + +=over 4 + +=item $Dpkg::PROGNAME + +Contains the name of the current program. + +=item $Dpkg::PROGVERSION + +Contains the version of the dpkg suite. + +=item $Dpkg::PROGMAKE + +Contains the name of the system GNU make program. + +=item $Dpkg::PROGTAR + +Contains the name of the system GNU tar program. + +=item $Dpkg::PROGPATCH + +Contains the name of the system GNU patch program (or another implementation +that is directory traversal resistant). + +=item $Dpkg::CONFDIR + +Contains the path to the dpkg system configuration directory. + +=item $Dpkg::ADMINDIR + +Contains the path to the dpkg database directory. + +=item $Dpkg::LIBDIR + +Contains the path to the dpkg methods and plugins directory. + +=item $Dpkg::DATADIR + +Contains the path to the dpkg architecture tables directory. + +=back + +=cut + +our ($PROGNAME) = $0 =~ m{(?:.*/)?([^/]*)}; + +# The following lines are automatically fixed at install time +our $PROGVERSION = '1.22.x'; +our $PROGMAKE = $ENV{DPKG_PROGMAKE} // 'make'; +our $PROGTAR = $ENV{DPKG_PROGTAR} // 'tar'; +our $PROGPATCH = $ENV{DPKG_PROGPATCH} // 'patch'; + +our $CONFDIR = '/etc/dpkg'; +our $ADMINDIR = '/var/lib/dpkg'; +our $LIBDIR = '.'; +our $DATADIR = '../data'; + +$DATADIR = $ENV{DPKG_DATADIR} if defined $ENV{DPKG_DATADIR}; + +=head1 MODULES + +The following is the list of public modules within the Dpkg hierarchy. Only +modules with versions 1.00 or higher, and only the interfaces documented in +their POD are considered public. + +=over + +=item L<Dpkg> + +This module, core variables. + +=item L<Dpkg::Arch> + +Architecture handling functions. + +=item L<Dpkg::BuildFlags> + +Set, modify and query compilation build flags. + +=item L<Dpkg::BuildInfo> + +Build information functions. + +=item L<Dpkg::BuildOptions> + +Parse and manipulate B<DEB_BUILD_OPTIONS>. + +=item L<Dpkg::BuildProfiles> + +Parse and manipulate build profiles. + +=item L<Dpkg::Changelog> + +Parse changelogs. + +=item L<Dpkg::Changelog::Entry> + +Represents a changelog entry. + +=item L<Dpkg::Changelog::Parse> + +Generic changelog parser for F<dpkg-parsechangelog>. + +=item L<Dpkg::Checksums> + +Generate and parse checksums. + +=item L<Dpkg::Compression> + +Simple database of available compression methods. + +=item L<Dpkg::Compression::FileHandle> + +Transparently compress and decompress files. + +=item L<Dpkg::Compression::Process> + +Wrapper around compression tools. + +=item L<Dpkg::Conf> + +Parse F<dpkg> configuration files. + +=item L<Dpkg::Control> + +Parse and manipulate Debian control information (F<.dsc>, F<.changes>, +F<Packages>/F<Sources> entries, etc.). + +=item L<Dpkg::Control::Changelog> + +Represent fields output by F<dpkg-parsechangelog>. + +=item L<Dpkg::Control::Fields> + +Manage (list of known) control fields. + +=item L<Dpkg::Control::Hash> + +Parse and manipulate a stanza of deb822 fields. + +=item L<Dpkg::Control::Info> + +Parse files like F<debian/control>. + +=item L<Dpkg::Control::Tests> + +Parse files like F<debian/tests/control>. + +=item L<Dpkg::Control::Tests::Entry> + +Represents a F<debian/tests/control> stanza. + +=item L<Dpkg::Deps> + +Parse and manipulate dependencies. + +=item L<Dpkg::Deps::Simple> + +Represents a single dependency statement. + +=item L<Dpkg::Deps::Multiple> + +Base module to represent multiple dependencies. + +=item L<Dpkg::Deps::Union> + +List of unrelated dependencies. + +=item L<Dpkg::Deps::AND> + +List of AND dependencies. + +=item L<Dpkg::Deps::OR> + +List of OR dependencies. + +=item L<Dpkg::Deps::KnownFacts> + +List of installed and virtual packages. + +=item L<Dpkg::Exit> + +Push, pop and run exit handlers. + +=item L<Dpkg::Gettext> + +Wrapper around L<Locale::gettext>. + +=item L<Dpkg::IPC> + +Spawn sub-processes and feed/retrieve data. + +=item L<Dpkg::Index> + +Collections of L<Dpkg::Control> (F<Packages>/F<Sources> files for example). + +=item L<Dpkg::Interface::Storable> + +Base object serializer. + +=item L<Dpkg::Path> + +Common path handling functions. + +=item L<Dpkg::Source::Format> + +Parse and manipulate debian/source/format files. + +=item L<Dpkg::Source::Package> + +Extract Debian source packages. + +=item L<Dpkg::Substvars> + +Substitute variables in strings. + +=item L<Dpkg::Vendor> + +Identify current distribution vendor. + +=item L<Dpkg::Version> + +Parse and manipulate Debian package versions. + +=back + +=head1 CHANGES + +=head2 Version 2.00 (dpkg 1.20.0) + +Remove variables: $version, $progname, $admindir, $dpkglibdir and $pkgdatadir. + +=head2 Version 1.03 (dpkg 1.18.24) + +New variable: $PROGPATCH. + +=head2 Version 1.02 (dpkg 1.18.11) + +New variable: $PROGTAR, $PROGMAKE. + +=head2 Version 1.01 (dpkg 1.17.0) + +New variables: $PROGNAME, $PROGVERSION, $CONFDIR, $ADMINDIR, $LIBDIR and +$DATADIR. + +Deprecated variables: $version, $admindir, $dpkglibdir and $pkgdatadir. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=head1 LICENSE + +See the header comment on each module for their particular license. + +=cut + +1; diff --git a/scripts/Dpkg/Arch.pm b/scripts/Dpkg/Arch.pm new file mode 100644 index 0000000..0d352ee --- /dev/null +++ b/scripts/Dpkg/Arch.pm @@ -0,0 +1,708 @@ +# 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/>. + +=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 + +package Dpkg::Arch 1.03; + +use strict; +use warnings; +use feature qw(state); + +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::BuildEnv; + +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::BuildEnv::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::BuildEnv::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 $cpu; + + ((undef) x 3, $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; + +=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 + +L<dpkg-architecture(1)>. diff --git a/scripts/Dpkg/Build/Info.pm b/scripts/Dpkg/Build/Info.pm new file mode 100644 index 0000000..efbfec7 --- /dev/null +++ b/scripts/Dpkg/Build/Info.pm @@ -0,0 +1,98 @@ +# Copyright © 2016-2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Build::Info - handle build information + +=head1 DESCRIPTION + +The Dpkg::Build::Info module provides functions to handle the build +information. + +This module is deprecated, use L<Dpkg::BuildInfo> instead. + +=cut + +package Dpkg::Build::Info 1.02; + +use strict; +use warnings; + +our @EXPORT_OK = qw( + get_build_env_whitelist + get_build_env_allowed +); + +use Exporter qw(import); + +use Dpkg::BuildInfo; + +=head1 FUNCTIONS + +=over 4 + +=item @envvars = get_build_env_allowed() + +Get an array with the allowed list of environment variables that can affect +the build, but are still not privacy revealing. + +This is a deprecated alias for Dpkg::BuildInfo::get_build_env_allowed(). + +=cut + +sub get_build_env_allowed { + #warnings::warnif('deprecated', + # 'Dpkg::Build::Info::get_build_env_allowed() is deprecated, ' . + # 'use Dpkg::BuildInfo::get_build_env_allowed() instead'); + return Dpkg::BuildInfo::get_build_env_allowed(); +} + +=item @envvars = get_build_env_whitelist() + +This is a deprecated alias for Dpkg::BuildInfo::get_build_env_allowed(). + +=cut + +sub get_build_env_whitelist { + warnings::warnif('deprecated', + 'Dpkg::Build::Info::get_build_env_whitelist() is deprecated, ' . + 'use Dpkg::BuildInfo::get_build_env_allowed() instead'); + return Dpkg::BuildInfo::get_build_env_allowed(); +} + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.21.14) + +Deprecate module: replaced by L<Dpkg::BuildInfo>. + +=head2 Version 1.01 (dpkg 1.20.1) + +New function: get_build_env_allowed(). + +Deprecated function: get_build_env_whitelist(). + +=head2 Version 1.00 (dpkg 1.18.14) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/BuildAPI.pm b/scripts/Dpkg/BuildAPI.pm new file mode 100644 index 0000000..d8f93e5 --- /dev/null +++ b/scripts/Dpkg/BuildAPI.pm @@ -0,0 +1,146 @@ +# Copyright © 2020-2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::BuildAPI - handle build API versions + +=head1 DESCRIPTION + +The Dpkg::BuildAPI module provides functions to fetch the current dpkg +build API level. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::BuildAPI 0.01; + +use strict; +use warnings; + +our @EXPORT_OK = qw( + get_build_api + reset_build_api +); + +use Exporter qw(import); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::BuildEnv; +use Dpkg::Version; +use Dpkg::Deps; + +use constant { + DEFAULT_BUILD_API => '0', + MAX_BUILD_API => '1', +}; + +my $build_api; + +=head1 FUNCTIONS + +=over 4 + +=item $level = get_build_api([$ctrl]) + +Get the build API level, from the environment variable B<DPKG_BUILD_API>, +or if not defined and a $ctrl L<Dpkg::Control::Info> object passed as an +argument, from its build dependency fields. If no $ctrl object gets passed +the previous value obtained is returned. + +=cut + +sub get_build_api { + my $ctrl = shift; + + return $build_api if defined $build_api && ! defined $ctrl; + + if (Dpkg::BuildEnv::has('DPKG_BUILD_API')) { + $build_api = Dpkg::BuildEnv::get('DPKG_BUILD_API'); + } elsif (defined $ctrl) { + my $src = $ctrl->get_source(); + my @dep_list = deps_concat(map { + $src->{$_ } + } qw(Build-Depends Build-Depends-Indep Build-Depends-Arch)); + + my $deps = deps_parse(@dep_list, + build_dep => 1, + reduce_restrictions => 1, + ); + + if (not defined $deps) { + $build_api = DEFAULT_BUILD_API; + return $build_api; + } + + deps_iterate($deps, sub { + my $dep = shift; + + return 1 if $dep->{package} ne 'dpkg-build-api'; + + if (! defined $dep->{relation} || $dep->{relation} ne REL_EQ) { + error(g_('dpkg build API level needs an exact version')); + } + + if (defined $build_api and $build_api ne $dep->{version}) { + error(g_('dpkg build API level with conflicting versions: %s vs %s'), + $build_api, $dep->{version}); + } + + $build_api = $dep->{version}; + + return 1; + }); + } + + $build_api //= DEFAULT_BUILD_API; + + if ($build_api !~ m/^[0-9]+$/) { + error(g_("invalid dpkg build API level '%s'"), $build_api); + } + + if ($build_api > MAX_BUILD_API) { + error(g_("dpkg build API level '%s' greater than max '%s'"), + $build_api, MAX_BUILD_API); + } + + return $build_api; +} + +=item reset_build_api() + +Reset the cached build API level. + +=cut + +sub reset_build_api { + $build_api = undef; +} + +=back + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/BuildEnv.pm b/scripts/Dpkg/BuildEnv.pm new file mode 100644 index 0000000..98ff3fd --- /dev/null +++ b/scripts/Dpkg/BuildEnv.pm @@ -0,0 +1,115 @@ +# Copyright © 2012 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::BuildEnv - track build environment + +=head1 DESCRIPTION + +The Dpkg::BuildEnv module is used by dpkg-buildflags to track the build +environment variables being used and modified. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::BuildEnv 0.01; + +use strict; +use warnings; + +my %env_modified = (); +my %env_accessed = (); + +=head1 FUNCTIONS + +=over 4 + +=item set($varname, $value) + +Update the build environment variable $varname with value $value. Record +it as being accessed and modified. + +=cut + +sub set { + my ($varname, $value) = @_; + $env_modified{$varname} = 1; + $env_accessed{$varname} = 1; + $ENV{$varname} = $value; +} + +=item get($varname) + +Get the build environment variable $varname value. Record it as being +accessed. + +=cut + +sub get { + my $varname = shift; + $env_accessed{$varname} = 1; + return $ENV{$varname}; +} + +=item has($varname) + +Return a boolean indicating whether the environment variable exists. +Record it as being accessed. + +=cut + +sub has { + my $varname = shift; + $env_accessed{$varname} = 1; + return exists $ENV{$varname}; +} + +=item @list = list_accessed() + +Returns a list of all environment variables that have been accessed. + +=cut + +sub list_accessed { + my @list = sort keys %env_accessed; + return @list; +} + +=item @list = list_modified() + +Returns a list of all environment variables that have been modified. + +=cut + +sub list_modified { + my @list = sort keys %env_modified; + return @list; +} + +=back + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/BuildFlags.pm b/scripts/Dpkg/BuildFlags.pm new file mode 100644 index 0000000..8aff53e --- /dev/null +++ b/scripts/Dpkg/BuildFlags.pm @@ -0,0 +1,599 @@ +# Copyright © 2010-2011 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2012-2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::BuildFlags - query build flags + +=head1 DESCRIPTION + +This class is used by dpkg-buildflags and can be used +to query the same information. + +=cut + +package Dpkg::BuildFlags 1.06; + +use strict; +use warnings; + +use Dpkg (); +use Dpkg::Gettext; +use Dpkg::BuildEnv; +use Dpkg::ErrorHandling; +use Dpkg::Vendor qw(run_vendor_hook); + +=head1 METHODS + +=over 4 + +=item $bf = Dpkg::BuildFlags->new() + +Create a new Dpkg::BuildFlags object. It will be initialized based +on the value of several configuration files and environment variables. + +If the option B<vendor_defaults> is set to false, then no vendor defaults are +initialized (it defaults to true). + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = { + }; + bless $self, $class; + + $opts{vendor_defaults} //= 1; + + if ($opts{vendor_defaults}) { + $self->load_vendor_defaults(); + } else { + $self->_init_vendor_defaults(); + } + return $self; +} + +sub _init_vendor_defaults { + my $self = shift; + + my @flags = qw( + ASFLAGS + ASFLAGS_FOR_BUILD + CPPFLAGS + CPPFLAGS_FOR_BUILD + CFLAGS + CFLAGS_FOR_BUILD + CXXFLAGS + CXXFLAGS_FOR_BUILD + OBJCFLAGS + OBJCFLAGS_FOR_BUILD + OBJCXXFLAGS + OBJCXXFLAGS_FOR_BUILD + DFLAGS + DFLAGS_FOR_BUILD + FFLAGS + FFLAGS_FOR_BUILD + FCFLAGS + FCFLAGS_FOR_BUILD + LDFLAGS + LDFLAGS_FOR_BUILD + ); + + $self->{features} = {}; + $self->{builtins} = {}; + $self->{optvals} = {}; + $self->{flags} = { map { $_ => '' } @flags }; + $self->{origin} = { map { $_ => 'vendor' } @flags }; + $self->{maintainer} = { map { $_ => 0 } @flags }; +} + +=item $bf->load_vendor_defaults() + +Reset the flags stored to the default set provided by the vendor. + +=cut + +sub load_vendor_defaults { + my $self = shift; + + $self->_init_vendor_defaults(); + + # The vendor hook will add the feature areas build flags. + run_vendor_hook('update-buildflags', $self); +} + +=item $bf->load_system_config() + +Update flags from the system configuration. + +=cut + +sub load_system_config { + my $self = shift; + + $self->update_from_conffile("$Dpkg::CONFDIR/buildflags.conf", 'system'); +} + +=item $bf->load_user_config() + +Update flags from the user configuration. + +=cut + +sub load_user_config { + my $self = shift; + + my $confdir = $ENV{XDG_CONFIG_HOME}; + $confdir ||= $ENV{HOME} . '/.config' if length $ENV{HOME}; + if (length $confdir) { + $self->update_from_conffile("$confdir/dpkg/buildflags.conf", 'user'); + } +} + +=item $bf->load_environment_config() + +Update flags based on user directives stored in the environment. See +L<dpkg-buildflags(1)> for details. + +=cut + +sub load_environment_config { + my $self = shift; + + foreach my $flag (keys %{$self->{flags}}) { + my $envvar = 'DEB_' . $flag . '_SET'; + if (Dpkg::BuildEnv::has($envvar)) { + $self->set($flag, Dpkg::BuildEnv::get($envvar), 'env'); + } + $envvar = 'DEB_' . $flag . '_STRIP'; + if (Dpkg::BuildEnv::has($envvar)) { + $self->strip($flag, Dpkg::BuildEnv::get($envvar), 'env'); + } + $envvar = 'DEB_' . $flag . '_APPEND'; + if (Dpkg::BuildEnv::has($envvar)) { + $self->append($flag, Dpkg::BuildEnv::get($envvar), 'env'); + } + $envvar = 'DEB_' . $flag . '_PREPEND'; + if (Dpkg::BuildEnv::has($envvar)) { + $self->prepend($flag, Dpkg::BuildEnv::get($envvar), 'env'); + } + } +} + +=item $bf->load_maintainer_config() + +Update flags based on maintainer directives stored in the environment. See +L<dpkg-buildflags(1)> for details. + +=cut + +sub load_maintainer_config { + my $self = shift; + + foreach my $flag (keys %{$self->{flags}}) { + my $envvar = 'DEB_' . $flag . '_MAINT_SET'; + if (Dpkg::BuildEnv::has($envvar)) { + $self->set($flag, Dpkg::BuildEnv::get($envvar), undef, 1); + } + $envvar = 'DEB_' . $flag . '_MAINT_STRIP'; + if (Dpkg::BuildEnv::has($envvar)) { + $self->strip($flag, Dpkg::BuildEnv::get($envvar), undef, 1); + } + $envvar = 'DEB_' . $flag . '_MAINT_APPEND'; + if (Dpkg::BuildEnv::has($envvar)) { + $self->append($flag, Dpkg::BuildEnv::get($envvar), undef, 1); + } + $envvar = 'DEB_' . $flag . '_MAINT_PREPEND'; + if (Dpkg::BuildEnv::has($envvar)) { + $self->prepend($flag, Dpkg::BuildEnv::get($envvar), undef, 1); + } + } +} + + +=item $bf->load_config() + +Call successively load_system_config(), load_user_config(), +load_environment_config() and load_maintainer_config() to update the +default build flags defined by the vendor. + +=cut + +sub load_config { + my $self = shift; + + $self->load_system_config(); + $self->load_user_config(); + $self->load_environment_config(); + $self->load_maintainer_config(); +} + +=item $bf->unset($flag) + +Unset the build flag $flag, so that it will not be known anymore. + +=cut + +sub unset { + my ($self, $flag) = @_; + + delete $self->{flags}->{$flag}; + delete $self->{origin}->{$flag}; + delete $self->{maintainer}->{$flag}; +} + +=item $bf->set($flag, $value, $source, $maint) + +Update the build flag $flag with value $value and record its origin as +$source (if defined). Record it as maintainer modified if $maint is +defined and true. + +=cut + +sub set { + my ($self, $flag, $value, $src, $maint) = @_; + $self->{flags}->{$flag} = $value; + $self->{origin}->{$flag} = $src if defined $src; + $self->{maintainer}->{$flag} = $maint if $maint; +} + +=item $bf->set_feature($area, $feature, $enabled) + +Update the boolean state of whether a specific feature within a known +feature area has been enabled. The only currently known feature areas +are "future", "qa", "sanitize", "optimize", "hardening" and "reproducible". + +=cut + +sub set_feature { + my ($self, $area, $feature, $enabled) = @_; + $self->{features}{$area}{$feature} = $enabled; +} + +=item $bf->get_feature($area, $feature) + +Returns the value for the given feature within a known feature area. +This is relevant for builtin features where the feature has a ternary +state of true, false and undef, and where the latter cannot be retrieved +with use_feature(). + +=cut + +sub get_feature { + my ($self, $area, $feature) = @_; + + return if ! $self->has_features($area); + return $self->{features}{$area}{$feature}; +} + +=item $bf->use_feature($area, $feature) + +Returns true if the given feature within a known feature areas has been +enabled, and false otherwise. +The only currently recognized feature areas are "future", "qa", "sanitize", +"optimize", "hardening" and "reproducible". + +=cut + +sub use_feature { + my ($self, $area, $feature) = @_; + + return 0 if ! $self->has_features($area); + return 0 if ! $self->{features}{$area}{$feature}; + return 1; +} + +=item $bf->set_builtin($area, $feature, $enabled) + +Update the boolean state of whether a specific feature within a known +feature area is handled (even if only in some architectures) as a builtin +default by the compiler. + +=cut + +sub set_builtin { + my ($self, $area, $feature, $enabled) = @_; + $self->{builtins}{$area}{$feature} = $enabled; +} + +=item $bf->get_builtins($area) + +Return, for the given area, a hash with keys as feature names, and values +as booleans indicating whether the feature is handled as a builtin default +by the compiler or not. Only features that might be handled as builtins on +some architectures are returned as part of the hash. Missing features mean +they are currently never handled as builtins by the compiler. + +=cut + +sub get_builtins { + my ($self, $area) = @_; + return if ! exists $self->{builtins}{$area}; + return %{$self->{builtins}{$area}}; +} + +=item $bf->set_option_value($option, $value) + +B<Private> method to set the value of a build option. +Do not use outside of the dpkg project. + +=cut + +sub set_option_value { + my ($self, $option, $value) = @_; + + $self->{optvals}{$option} = $value; +} + +=item $bf->get_option_value($option) + +B<Private> method to get the value of a build option. +Do not use outside of the dpkg project. + +=cut + +sub get_option_value { + my ($self, $option) = @_; + + return $self->{optvals}{$option}; +} + +=item $bf->strip($flag, $value, $source, $maint) + +Update the build flag $flag by stripping the flags listed in $value and +record its origin as $source (if defined). Record it as maintainer modified +if $maint is defined and true. + +=cut + +sub strip { + my ($self, $flag, $value, $src, $maint) = @_; + + my %strip = map { $_ => 1 } split /\s+/, $value; + + $self->{flags}->{$flag} = join q{ }, grep { + ! exists $strip{$_} + } split q{ }, $self->{flags}{$flag}; + $self->{origin}->{$flag} = $src if defined $src; + $self->{maintainer}->{$flag} = $maint if $maint; +} + +=item $bf->append($flag, $value, $source, $maint) + +Append the options listed in $value to the current value of the flag $flag. +Record its origin as $source (if defined). Record it as maintainer modified +if $maint is defined and true. + +=cut + +sub append { + my ($self, $flag, $value, $src, $maint) = @_; + if (length($self->{flags}->{$flag})) { + $self->{flags}->{$flag} .= " $value"; + } else { + $self->{flags}->{$flag} = $value; + } + $self->{origin}->{$flag} = $src if defined $src; + $self->{maintainer}->{$flag} = $maint if $maint; +} + +=item $bf->prepend($flag, $value, $source, $maint) + +Prepend the options listed in $value to the current value of the flag $flag. +Record its origin as $source (if defined). Record it as maintainer modified +if $maint is defined and true. + +=cut + +sub prepend { + my ($self, $flag, $value, $src, $maint) = @_; + if (length($self->{flags}->{$flag})) { + $self->{flags}->{$flag} = "$value " . $self->{flags}->{$flag}; + } else { + $self->{flags}->{$flag} = $value; + } + $self->{origin}->{$flag} = $src if defined $src; + $self->{maintainer}->{$flag} = $maint if $maint; +} + + +=item $bf->update_from_conffile($file, $source) + +Update the current build flags based on the configuration directives +contained in $file. See L<dpkg-buildflags(1)> for the format of the directives. + +$source is the origin recorded for any build flag set or modified. + +=cut + +sub update_from_conffile { + my ($self, $file, $src) = @_; + local $_; + + return unless -e $file; + open(my $conf_fh, '<', $file) or syserr(g_('cannot read %s'), $file); + while (<$conf_fh>) { + chomp; + next if /^\s*#/; # Skip comments + next if /^\s*$/; # Skip empty lines + if (/^(append|prepend|set|strip)\s+(\S+)\s+(\S.*\S)\s*$/i) { + my ($op, $flag, $value) = ($1, $2, $3); + unless (exists $self->{flags}->{$flag}) { + warning(g_('line %d of %s mentions unknown flag %s'), $., $file, $flag); + $self->{flags}->{$flag} = ''; + } + if (lc($op) eq 'set') { + $self->set($flag, $value, $src); + } elsif (lc($op) eq 'strip') { + $self->strip($flag, $value, $src); + } elsif (lc($op) eq 'append') { + $self->append($flag, $value, $src); + } elsif (lc($op) eq 'prepend') { + $self->prepend($flag, $value, $src); + } + } else { + warning(g_('line %d of %s is invalid, it has been ignored'), $., $file); + } + } + close($conf_fh); +} + +=item $bf->get($flag) + +Return the value associated to the flag. It might be undef if the +flag doesn't exist. + +=cut + +sub get { + my ($self, $key) = @_; + return $self->{flags}{$key}; +} + +=item $bf->get_feature_areas() + +Return the feature areas (i.e. the area values has_features will return +true for). + +=cut + +sub get_feature_areas { + my $self = shift; + + return keys %{$self->{features}}; +} + +=item $bf->get_features($area) + +Return, for the given area, a hash with keys as feature names, and values +as booleans indicating whether the feature is enabled or not. + +=cut + +sub get_features { + my ($self, $area) = @_; + return %{$self->{features}{$area}}; +} + +=item $bf->get_origin($flag) + +Return the origin associated to the flag. It might be undef if the +flag doesn't exist. + +=cut + +sub get_origin { + my ($self, $key) = @_; + return $self->{origin}{$key}; +} + +=item $bf->is_maintainer_modified($flag) + +Return true if the flag is modified by the maintainer. + +=cut + +sub is_maintainer_modified { + my ($self, $key) = @_; + return $self->{maintainer}{$key}; +} + +=item $bf->has_features($area) + +Returns true if the given area of features is known, and false otherwise. +The only currently recognized feature areas are "future", "qa", "sanitize", +"optimize", "hardening" and "reproducible". + +=cut + +sub has_features { + my ($self, $area) = @_; + return exists $self->{features}{$area}; +} + +=item $bf->has($option) + +Returns a boolean indicating whether the flags exists in the object. + +=cut + +sub has { + my ($self, $key) = @_; + return exists $self->{flags}{$key}; +} + +=item @flags = $bf->list() + +Returns the list of flags stored in the object. + +=cut + +sub list { + my $self = shift; + my @list = sort keys %{$self->{flags}}; + return @list; +} + +=back + +=head1 CHANGES + +=head2 Version 1.06 (dpkg 1.21.15) + +New method: $bf->get_feature(). + +=head2 Version 1.05 (dpkg 1.21.14) + +New option: 'vendor_defaults' in new(). + +New methods: $bf->load_vendor_defaults(), $bf->use_feature(), +$bf->set_builtin(), $bf->get_builtins(). + +=head2 Version 1.04 (dpkg 1.20.0) + +New method: $bf->unset(). + +=head2 Version 1.03 (dpkg 1.16.5) + +New method: $bf->get_feature_areas() to list possible values for +$bf->get_features. + +New method $bf->is_maintainer_modified() and new optional parameter to +$bf->set(), $bf->append(), $bf->prepend(), $bf->strip(). + +=head2 Version 1.02 (dpkg 1.16.2) + +New methods: $bf->get_features(), $bf->has_features(), $bf->set_feature(). + +=head2 Version 1.01 (dpkg 1.16.1) + +New method: $bf->prepend() very similar to append(). Implement support of +the prepend operation everywhere. + +New method: $bf->load_maintainer_config() that update the build flags +based on the package maintainer directives. + +=head2 Version 1.00 (dpkg 1.15.7) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/BuildInfo.pm b/scripts/Dpkg/BuildInfo.pm new file mode 100644 index 0000000..0792659 --- /dev/null +++ b/scripts/Dpkg/BuildInfo.pm @@ -0,0 +1,163 @@ +# Copyright © 2016-2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::BuildInfo - handle build information + +=head1 DESCRIPTION + +The Dpkg::BuildInfo module provides functions to handle the build +information. + +=cut + +package Dpkg::BuildInfo 1.00; + +use strict; +use warnings; + +our @EXPORT_OK = qw( + get_build_env_allowed +); + +use Exporter qw(import); + +=head1 FUNCTIONS + +=over 4 + +=item @envvars = get_build_env_allowed() + +Get an array with the allowed list of environment variables that can affect +the build, but are still not privacy revealing. + +=cut + +my @env_allowed = ( + # Toolchain. + qw( + CC + CPP + CXX + OBJC + OBJCXX + PC + FC + M2C + AS + LD + AR + RANLIB + MAKE + AWK + LEX + YACC + ), + # Toolchain flags. + qw( + ASFLAGS + ASFLAGS_FOR_BUILD + CFLAGS + CFLAGS_FOR_BUILD + CPPFLAGS + CPPFLAGS_FOR_BUILD + CXXFLAGS + CXXFLAGS_FOR_BUILD + OBJCFLAGS + OBJCFLAGS_FOR_BUILD + OBJCXXFLAGS + OBJCXXFLAGS_FOR_BUILD + DFLAGS + DFLAGS_FOR_BUILD + FFLAGS + FFLAGS_FOR_BUILD + LDFLAGS + LDFLAGS_FOR_BUILD + ARFLAGS + MAKEFLAGS + ), + # Dynamic linker, see ld(1). + qw( + LD_LIBRARY_PATH + ), + # Locale, see locale(1). + qw( + LANG + LC_ALL + LC_CTYPE + LC_NUMERIC + LC_TIME + LC_COLLATE + LC_MONETARY + LC_MESSAGES + LC_PAPER + LC_NAME + LC_ADDRESS + LC_TELEPHONE + LC_MEASUREMENT + LC_IDENTIFICATION + ), + # Build flags, see dpkg-buildpackage(1). + qw( + DEB_BUILD_OPTIONS + DEB_BUILD_PROFILES + ), + # DEB_flag_{SET,STRIP,APPEND,PREPEND} will be recorded after being merged + # with system config and user config. + # See deb-vendor(1). + qw( + DEB_VENDOR + ), + # See dpkg(1). + qw( + DPKG_ROOT + DPKG_ADMINDIR + ), + # See dpkg-architecture(1). + qw( + DPKG_DATADIR + ), + # See Dpkg::Vendor(3). + qw( + DPKG_ORIGINS_DIR + ), + # See dpkg-gensymbols(1). + qw( + DPKG_GENSYMBOLS_CHECK_LEVEL + ), + # See <https://reproducible-builds.org/specs/source-date-epoch>. + qw( + SOURCE_DATE_EPOCH + ), +); + +sub get_build_env_allowed { + return @env_allowed; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.21.14) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/BuildOptions.pm b/scripts/Dpkg/BuildOptions.pm new file mode 100644 index 0000000..5b53655 --- /dev/null +++ b/scripts/Dpkg/BuildOptions.pm @@ -0,0 +1,249 @@ +# Copyright © 2007 Frank Lichtenheld <djpig@debian.org> +# Copyright © 2008, 2012-2017 Guillem Jover <guillem@debian.org> +# Copyright © 2010 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::BuildOptions - parse and update build options + +=head1 DESCRIPTION + +This class can be used to manipulate options stored +in environment variables like DEB_BUILD_OPTIONS and +DEB_BUILD_MAINT_OPTIONS. + +=cut + +package Dpkg::BuildOptions 1.02; + +use strict; +use warnings; + +use List::Util qw(any); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::BuildEnv; + +=head1 METHODS + +=over 4 + +=item $bo = Dpkg::BuildOptions->new(%opts) + +Create a new Dpkg::BuildOptions object. It will be initialized based +on the value of the environment variable named $opts{envvar} (or +DEB_BUILD_OPTIONS if that option is not set). + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = { + options => {}, + source => {}, + envvar => $opts{envvar} // 'DEB_BUILD_OPTIONS', + }; + bless $self, $class; + $self->merge(Dpkg::BuildEnv::get($self->{envvar}), $self->{envvar}); + return $self; +} + +=item $bo->reset() + +Reset the object to not have any option (it's empty). + +=cut + +sub reset { + my $self = shift; + $self->{options} = {}; + $self->{source} = {}; +} + +=item $bo->merge($content, $source) + +Merge the options set in $content and record that they come from the +source $source. $source is mainly used in warning messages currently +to indicate where invalid options have been detected. + +$content is a space separated list of options with optional assigned +values like "nocheck parallel=2". + +=cut + +sub merge { + my ($self, $content, $source) = @_; + return 0 unless defined $content; + my $count = 0; + foreach (split(/\s+/, $content)) { + unless (/^([a-z][a-z0-9_-]*)(?:=(\S*))?$/) { + warning(g_('invalid flag in %s: %s'), $source, $_); + next; + } + ## no critic (RegularExpressions::ProhibitCaptureWithoutTest) + $count += $self->set($1, $2, $source); + } + return $count; +} + +=item $bo->set($option, $value, [$source]) + +Store the given option in the object with the given value. It's legitimate +for a value to be undefined if the option is a simple boolean (its +presence means true, its absence means false). The $source is optional +and indicates where the option comes from. + +The known options have their values checked for sanity. Options without +values have their value removed and options with invalid values are +discarded. + +=cut + +sub set { + my ($self, $key, $value, $source) = @_; + + # Sanity checks + if (any { $_ eq $key } qw(terse noopt nostrip nocheck) and defined $value) { + $value = undef; + } elsif ($key eq 'parallel') { + $value //= ''; + return 0 if $value !~ /^\d*$/; + } + + $self->{options}{$key} = $value; + $self->{source}{$key} = $source; + + return 1; +} + +=item $bo->get($option) + +Return the value associated to the option. It might be undef even if the +option exists. You might want to check with $bo->has($option) to verify if +the option is stored in the object. + +=cut + +sub get { + my ($self, $key) = @_; + return $self->{options}{$key}; +} + +=item $bo->has($option) + +Returns a boolean indicating whether the option is stored in the object. + +=cut + +sub has { + my ($self, $key) = @_; + return exists $self->{options}{$key}; +} + +=item $bo->parse_features($option, $use_feature) + +Parse the $option values, as a set of known features to enable or disable, +as specified in the $use_feature hash reference. + +Each feature is prefixed with a 'B<+>' or a 'B<->' character as a marker +to enable or disable it. The special feature "B<all>" can be used to act +on all known features. + +Unknown or malformed features will emit warnings. + +=cut + +sub parse_features { + my ($self, $option, $use_feature) = @_; + + foreach my $feature (split(/,/, $self->get($option) // '')) { + $feature = lc $feature; + if ($feature =~ s/^([+-])//) { + my $value = ($1 eq '+') ? 1 : 0; + if ($feature eq 'all') { + $use_feature->{$_} = $value foreach keys %{$use_feature}; + } else { + if (exists $use_feature->{$feature}) { + $use_feature->{$feature} = $value; + } else { + warning(g_('unknown %s feature in %s variable: %s'), + $option, $self->{envvar}, $feature); + } + } + } else { + warning(g_('incorrect value in %s option of %s variable: %s'), + $option, $self->{envvar}, $feature); + } + } +} + +=item $string = $bo->output($fh) + +Return a string representation of the build options suitable to be +assigned to an environment variable. Can optionally output that string to +the given filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + my $o = $self->{options}; + my $res = join(' ', map { defined($o->{$_}) ? $_ . '=' . $o->{$_} : $_ } sort keys %$o); + print { $fh } $res if defined $fh; + return $res; +} + +=item $bo->export([$var]) + +Export the build options to the given environment variable. If omitted, +the environment variable defined at creation time is assumed. The value +set to the variable is also returned. + +=cut + +sub export { + my ($self, $var) = @_; + $var //= $self->{envvar}; + my $content = $self->output(); + Dpkg::BuildEnv::set($var, $content); + return $content; +} + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.18.19) + +New method: $bo->parse_features(). + +=head2 Version 1.01 (dpkg 1.16.1) + +Enable to use another environment variable instead of DEB_BUILD_OPTIONS. +Thus add support for the "envvar" option at creation time. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/BuildProfiles.pm b/scripts/Dpkg/BuildProfiles.pm new file mode 100644 index 0000000..ebfce54 --- /dev/null +++ b/scripts/Dpkg/BuildProfiles.pm @@ -0,0 +1,148 @@ +# Copyright © 2013 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::BuildProfiles - handle build profiles + +=head1 DESCRIPTION + +The Dpkg::BuildProfiles module provides functions to handle the build +profiles. + +=cut + +package Dpkg::BuildProfiles 1.00; + +use strict; +use warnings; + +our @EXPORT_OK = qw( + get_build_profiles + set_build_profiles + parse_build_profiles + evaluate_restriction_formula +); + +use Exporter qw(import); +use List::Util qw(any); + +use Dpkg::BuildEnv; + +my $cache_profiles; +my @build_profiles; + +=head1 FUNCTIONS + +=over 4 + +=item @profiles = get_build_profiles() + +Get an array with the currently active build profiles, taken from +the environment variable B<DEB_BUILD_PROFILES>. + +=cut + +sub get_build_profiles { + return @build_profiles if $cache_profiles; + + if (Dpkg::BuildEnv::has('DEB_BUILD_PROFILES')) { + @build_profiles = split ' ', Dpkg::BuildEnv::get('DEB_BUILD_PROFILES'); + } + $cache_profiles = 1; + + return @build_profiles; +} + +=item set_build_profiles(@profiles) + +Set C<@profiles> as the current active build profiles, by setting +the environment variable B<DEB_BUILD_PROFILES>. + +=cut + +sub set_build_profiles { + my (@profiles) = @_; + + $cache_profiles = 1; + @build_profiles = @profiles; + Dpkg::BuildEnv::set('DEB_BUILD_PROFILES', join ' ', @profiles); +} + +=item @profiles = parse_build_profiles($string) + +Parses a build profiles specification, into an array of array references. + +=cut + +sub parse_build_profiles { + my $string = shift; + + $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; + + return map { [ split ' ' ] } split /\s*>\s+<\s*/, $string; +} + +=item evaluate_restriction_formula(\@formula, \@profiles) + +Evaluate whether a restriction formula of the form "<foo bar> <baz>", given as +a nested array, is true or false, given the array of enabled build profiles. + +=cut + +sub evaluate_restriction_formula { + my ($formula, $profiles) = @_; + + # Restriction formulas are in disjunctive normal form: + # (foo AND bar) OR (blub AND bla) + foreach my $restrlist (@{$formula}) { + my $seen_profile = 1; + + foreach my $restriction (@$restrlist) { + next if $restriction !~ m/^(!)?(.+)/; + + ## no critic (RegularExpressions::ProhibitCaptureWithoutTest) + my $negated = defined $1 && $1 eq '!'; + my $profile = $2; + my $found = any { $_ eq $profile } @{$profiles}; + + # If a negative set profile is encountered, stop processing. + # If a positive unset profile is encountered, stop processing. + if ($found == $negated) { + $seen_profile = 0; + last; + } + } + + # This conjunction evaluated to true so we don't have to evaluate + # the others. + return 1 if $seen_profile; + } + return 0; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.17.17) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/BuildTree.pm b/scripts/Dpkg/BuildTree.pm new file mode 100644 index 0000000..7943eb4 --- /dev/null +++ b/scripts/Dpkg/BuildTree.pm @@ -0,0 +1,115 @@ +# Copyright © 2023 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::BuildTree - handle build tree actions + +=head1 DESCRIPTION + +The Dpkg::BuildTree module provides functions to handle build tree actions. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::BuildTree 0.01; + +use strict; +use warnings; + +use Cwd; + +use Dpkg::Source::Functions qw(erasedir); + +=head1 METHODS + +=over 4 + +=item $bt = Dpkg::BuildTree->new(%opts) + +Create a new Dpkg::BuildTree object. +Supported options are: + +=over 8 + +=item dir + +The build tree directory. +If not specified, it assumes the current working directory. + +=back + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = { + buildtree => $opts{dir} || getcwd(), + }; + bless $self, $class; + + return $self; +} + +=item $bt->clean() + +Clean the build tree, by removing any dpkg generated artifacts. + +=cut + +sub clean { + my $self = shift; + + my $buildtree = $self->{buildtree}; + + # If this does not look like a build tree, do nothing. + return unless -f "$buildtree/debian/control"; + + my @files = qw( + debian/files + debian/files.new + debian/substvars + debian/substvars.new + ); + my @dirs = qw( + debian/tmp + ); + + foreach my $file (@files) { + unlink "$buildtree/$file"; + } + foreach my $dir (@dirs) { + erasedir("$buildtree/$dir"); + } + + return; +} + +=back + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/BuildTypes.pm b/scripts/Dpkg/BuildTypes.pm new file mode 100644 index 0000000..7614ee6 --- /dev/null +++ b/scripts/Dpkg/BuildTypes.pm @@ -0,0 +1,287 @@ +# Copyright © 2007 Frank Lichtenheld <djpig@debian.org> +# Copyright © 2010, 2013-2016 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::BuildTypes - track build types + +=head1 DESCRIPTION + +The Dpkg::BuildTypes module is used by various tools to track and decide +what artifacts need to be built. + +The build types are bit constants that are exported by default. Multiple +types can be ORed. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::BuildTypes 0.02; + +use strict; +use warnings; + +our @EXPORT = qw( + BUILD_DEFAULT + BUILD_SOURCE + BUILD_ARCH_DEP + BUILD_ARCH_INDEP + BUILD_BINARY + BUILD_FULL + build_has_any + build_has_all + build_has_none + build_is + set_build_type + set_build_type_from_options + set_build_type_from_targets + get_build_options_from_type +); + +use Exporter qw(import); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +=head1 CONSTANTS + +=over 4 + +=item BUILD_DEFAULT + +This build is the default. + +=item BUILD_SOURCE + +This build includes source artifacts. + +=item BUILD_ARCH_DEP + +This build includes architecture dependent binary artifacts. + +=item BUILD_ARCH_INDEP + +This build includes architecture independent binary artifacts. + +=item BUILD_BINARY + +This build includes binary artifacts. + +=item BUILD_FULL + +This build includes source and binary artifacts. + +=cut + +# Simple types. +use constant { + BUILD_DEFAULT => 1, + BUILD_SOURCE => 2, + BUILD_ARCH_DEP => 4, + BUILD_ARCH_INDEP => 8, +}; + +# Composed types. +use constant BUILD_BINARY => BUILD_ARCH_DEP | BUILD_ARCH_INDEP; +use constant BUILD_FULL => BUILD_BINARY | BUILD_SOURCE; + +my $current_type = BUILD_FULL | BUILD_DEFAULT; +my $current_option = undef; + +my @build_types = qw(full source binary any all); +my %build_types = ( + full => BUILD_FULL, + source => BUILD_SOURCE, + binary => BUILD_BINARY, + any => BUILD_ARCH_DEP, + all => BUILD_ARCH_INDEP, +); +my %build_targets = ( + 'clean' => BUILD_SOURCE, + 'build' => BUILD_BINARY, + 'build-arch' => BUILD_ARCH_DEP, + 'build-indep' => BUILD_ARCH_INDEP, + 'binary' => BUILD_BINARY, + 'binary-arch' => BUILD_ARCH_DEP, + 'binary-indep' => BUILD_ARCH_INDEP, +); + +=back + +=head1 FUNCTIONS + +=over 4 + +=item build_has_any($bits) + +Return a boolean indicating whether the current build type has any of the +specified $bits. + +=cut + +sub build_has_any +{ + my ($bits) = @_; + + return $current_type & $bits; +} + +=item build_has_all($bits) + +Return a boolean indicating whether the current build type has all the +specified $bits. + +=cut + +sub build_has_all +{ + my ($bits) = @_; + + return ($current_type & $bits) == $bits; +} + +=item build_has_none($bits) + +Return a boolean indicating whether the current build type has none of the +specified $bits. + +=cut + +sub build_has_none +{ + my ($bits) = @_; + + return !($current_type & $bits); +} + +=item build_is($bits) + +Return a boolean indicating whether the current build type is the specified +set of $bits. + +=cut + +sub build_is +{ + my ($bits) = @_; + + return $current_type == $bits; +} + +=item set_build_type($build_type, $build_option, %opts) + +Set the current build type to $build_type, which was specified via the +$build_option command-line option. + +The function will check and abort on incompatible build type assignments, +this behavior can be disabled by using the boolean option "nocheck". + +=cut + +sub set_build_type +{ + my ($build_type, $build_option, %opts) = @_; + + usageerr(g_('cannot combine %s and %s'), $current_option, $build_option) + if not $opts{nocheck} and + build_has_none(BUILD_DEFAULT) and $current_type != $build_type; + + $current_type = $build_type; + $current_option = $build_option; +} + +=item set_build_type_from_options($build_types, $build_option, %opts) + +Set the current build type from a list of comma-separated build type +components. + +The function will check and abort on incompatible build type assignments, +this behavior can be disabled by using the boolean option "nocheck". + +=cut + +sub set_build_type_from_options +{ + my ($build_parts, $build_option, %opts) = @_; + + my $build_type = 0; + foreach my $type (split /,/, $build_parts) { + usageerr(g_('unknown build type %s'), $type) + unless exists $build_types{$type}; + $build_type |= $build_types{$type}; + } + + set_build_type($build_type, $build_option, %opts); +} + +=item set_build_type_from_targets($build_targets, $build_option, %opts) + +Set the current build type from a list of comma-separated build target +components. + +The function will check and abort on incompatible build type assignments, +this behavior can be disabled by using the boolean option "nocheck". + +=cut + +sub set_build_type_from_targets +{ + my ($build_targets, $build_option, %opts) = @_; + + my $build_type = 0; + foreach my $target (split /,/, $build_targets) { + $build_type |= $build_targets{$target} // BUILD_BINARY; + } + + set_build_type($build_type, $build_option, %opts); +} + +=item get_build_options_from_type() + +Get the current build type as a set of comma-separated string options. + +=cut + +sub get_build_options_from_type +{ + my $local_type = $current_type; + + my @parts; + foreach my $type (@build_types) { + my $part_bits = $build_types{$type}; + if (($local_type & $part_bits) == $part_bits) { + push @parts, $type; + $local_type &= ~$part_bits; + } + } + + return join ',', @parts; +} + +=back + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Changelog.pm b/scripts/Dpkg/Changelog.pm new file mode 100644 index 0000000..6de7bf3 --- /dev/null +++ b/scripts/Dpkg/Changelog.pm @@ -0,0 +1,775 @@ +# Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de> +# Copyright © 2009 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Changelog - base class to implement a changelog parser + +=head1 DESCRIPTION + +Dpkg::Changelog is a class representing a changelog file +as an array of changelog entries (L<Dpkg::Changelog::Entry>). +By deriving this class and implementing its parse() method, you +add the ability to fill this object with changelog entries. + +=cut + +package Dpkg::Changelog 2.00; + +use strict; +use warnings; + +use Carp; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling qw(:DEFAULT report REPORT_WARN); +use Dpkg::Control; +use Dpkg::Control::Changelog; +use Dpkg::Control::Fields; +use Dpkg::Index; +use Dpkg::Version; +use Dpkg::Vendor qw(run_vendor_hook); + +use parent qw(Dpkg::Interface::Storable); + +use overload + '@{}' => sub { return $_[0]->{data} }; + +=head1 METHODS + +=over 4 + +=item $c = Dpkg::Changelog->new(%options) + +Creates a new changelog object. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + my $self = { + verbose => 1, + parse_errors => [] + }; + bless $self, $class; + $self->set_options(%opts); + return $self; +} + +=item $c->set_options(%opts) + +Change the value of some options. "verbose" (defaults to 1) defines +whether parse errors are displayed as warnings by default. "reportfile" +is a string to use instead of the name of the file parsed, in particular +in error messages. "range" defines the range of entries that we want to +parse, the parser will stop as soon as it has parsed enough data to +satisfy $c->get_range($opts{range}). + +=cut + +sub set_options { + my ($self, %opts) = @_; + $self->{$_} = $opts{$_} foreach keys %opts; +} + +=item $count = $c->parse($fh, $description) + +Read the filehandle and parse a changelog in it. The data in the object is +reset before parsing new data. + +Returns the number of changelog entries that have been parsed with success. + +This method needs to be implemented by one of the specialized changelog +format subclasses. + +=item $count = $c->load($filename) + +Parse $filename contents for a changelog. + +Returns the number of changelog entries that have been parsed with success. + +=item $c->reset_parse_errors() + +Can be used to delete all information about errors occurred during +previous parse() runs. + +=cut + +sub reset_parse_errors { + my $self = shift; + $self->{parse_errors} = []; +} + +=item $c->parse_error($file, $line_nr, $error, [$line]) + +Record a new parse error in $file at line $line_nr. The error message is +specified with $error and a copy of the line can be recorded in $line. + +=cut + +sub parse_error { + my ($self, $file, $line_nr, $error, $line) = @_; + + push @{$self->{parse_errors}}, [ $file, $line_nr, $error, $line ]; + + if ($self->{verbose}) { + if ($line) { + warning("%20s(l$line_nr): $error\nLINE: $line", $file); + } else { + warning("%20s(l$line_nr): $error", $file); + } + } +} + +=item $c->get_parse_errors() + +Returns all error messages from the last parse() run. +If called in scalar context returns a human readable +string representation. If called in list context returns +an array of arrays. Each of these arrays contains + +=over 4 + +=item 1. + +a string describing the origin of the data (a filename usually). If the +reportfile configuration option was given, its value will be used instead. + +=item 2. + +the line number where the error occurred + +=item 3. + +an error description + +=item 4. + +the original line + +=back + +=cut + +sub get_parse_errors { + my $self = shift; + + if (wantarray) { + return @{$self->{parse_errors}}; + } else { + my $res = ''; + foreach my $e (@{$self->{parse_errors}}) { + if ($e->[3]) { + $res .= report(REPORT_WARN, g_("%s(l%s): %s\nLINE: %s"), @$e); + } else { + $res .= report(REPORT_WARN, g_('%s(l%s): %s'), @$e); + } + } + return $res; + } +} + +=item $c->set_unparsed_tail($tail) + +Add a string representing unparsed lines after the changelog entries. +Use undef as $tail to remove the unparsed lines currently set. + +=item $c->get_unparsed_tail() + +Return a string representing the unparsed lines after the changelog +entries. Returns undef if there's no such thing. + +=cut + +sub set_unparsed_tail { + my ($self, $tail) = @_; + $self->{unparsed_tail} = $tail; +} + +sub get_unparsed_tail { + my $self = shift; + return $self->{unparsed_tail}; +} + +=item @{$c} + +Returns all the L<Dpkg::Changelog::Entry> objects contained in this changelog +in the order in which they have been parsed. + +=item $c->get_range($range) + +Returns an array (if called in list context) or a reference to an array of +L<Dpkg::Changelog::Entry> objects which each represent one entry of the +changelog. $range is a hash reference describing the range of entries +to return. See section L</RANGE SELECTION>. + +=cut + +sub _sanitize_range { + my ($self, $r) = @_; + my $data = $self->{data}; + + if (defined($r->{offset}) and not defined($r->{count})) { + warning(g_("'offset' without 'count' has no effect")) if $self->{verbose}; + delete $r->{offset}; + } + + ## no critic (ControlStructures::ProhibitUntilBlocks) + if ((defined($r->{count}) || defined($r->{offset})) && + (defined($r->{from}) || defined($r->{since}) || + defined($r->{to}) || defined($r->{until}))) + { + warning(g_("you can't combine 'count' or 'offset' with any other " . + 'range option')) if $self->{verbose}; + delete $r->{from}; + delete $r->{since}; + delete $r->{to}; + delete $r->{until}; + } + if (defined($r->{from}) && defined($r->{since})) { + warning(g_("you can only specify one of 'from' and 'since', using " . + "'since'")) if $self->{verbose}; + delete $r->{from}; + } + if (defined($r->{to}) && defined($r->{until})) { + warning(g_("you can only specify one of 'to' and 'until', using " . + "'until'")) if $self->{verbose}; + delete $r->{to}; + } + + # Handle non-existing versions + my (%versions, @versions); + foreach my $entry (@{$data}) { + my $version = $entry->get_version(); + next unless defined $version; + $versions{$version->as_string()} = 1; + push @versions, $version->as_string(); + } + if ((defined($r->{since}) and not exists $versions{$r->{since}})) { + warning(g_("'%s' option specifies non-existing version '%s'"), 'since', $r->{since}); + warning(g_('use newest entry that is earlier than the one specified')); + foreach my $v (@versions) { + if (version_compare_relation($v, REL_LT, $r->{since})) { + $r->{since} = $v; + last; + } + } + if (not exists $versions{$r->{since}}) { + # No version was earlier, include all + warning(g_('none found, starting from the oldest entry')); + delete $r->{since}; + $r->{from} = $versions[-1]; + } + } + if ((defined($r->{from}) and not exists $versions{$r->{from}})) { + warning(g_("'%s' option specifies non-existing version '%s'"), 'from', $r->{from}); + warning(g_('use oldest entry that is later than the one specified')); + my $oldest; + foreach my $v (@versions) { + if (version_compare_relation($v, REL_GT, $r->{from})) { + $oldest = $v; + } + } + if (defined($oldest)) { + $r->{from} = $oldest; + } else { + warning(g_("no such entry found, ignoring '%s' parameter '%s'"), 'from', $r->{from}); + delete $r->{from}; # No version was oldest + } + } + if (defined($r->{until}) and not exists $versions{$r->{until}}) { + warning(g_("'%s' option specifies non-existing version '%s'"), 'until', $r->{until}); + warning(g_('use oldest entry that is later than the one specified')); + my $oldest; + foreach my $v (@versions) { + if (version_compare_relation($v, REL_GT, $r->{until})) { + $oldest = $v; + } + } + if (defined($oldest)) { + $r->{until} = $oldest; + } else { + warning(g_("no such entry found, ignoring '%s' parameter '%s'"), 'until', $r->{until}); + delete $r->{until}; # No version was oldest + } + } + if (defined($r->{to}) and not exists $versions{$r->{to}}) { + warning(g_("'%s' option specifies non-existing version '%s'"), 'to', $r->{to}); + warning(g_('use newest entry that is earlier than the one specified')); + foreach my $v (@versions) { + if (version_compare_relation($v, REL_LT, $r->{to})) { + $r->{to} = $v; + last; + } + } + if (not exists $versions{$r->{to}}) { + # No version was earlier + warning(g_("no such entry found, ignoring '%s' parameter '%s'"), 'to', $r->{to}); + delete $r->{to}; + } + } + + if (defined($r->{since}) and $data->[0]->get_version() eq $r->{since}) { + warning(g_("'since' option specifies most recent version '%s', ignoring"), $r->{since}); + delete $r->{since}; + } + if (defined($r->{until}) and $data->[-1]->get_version() eq $r->{until}) { + warning(g_("'until' option specifies oldest version '%s', ignoring"), $r->{until}); + delete $r->{until}; + } + ## use critic +} + +sub get_range { + my ($self, $range) = @_; + $range //= {}; + my $res = $self->_data_range($range); + return unless defined $res; + if (wantarray) { + return reverse @{$res} if $range->{reverse}; + return @{$res}; + } else { + return $res; + } +} + +sub _is_full_range { + my ($self, $range) = @_; + + return 1 if $range->{all}; + + # If no range delimiter is specified, we want everything. + foreach my $delim (qw(since until from to count offset)) { + return 0 if exists $range->{$delim}; + } + + return 1; +} + +sub _data_range { + my ($self, $range) = @_; + + my $data = $self->{data} or return; + + return [ @$data ] if $self->_is_full_range($range); + + $self->_sanitize_range($range); + + my ($start, $end); + if (defined($range->{count})) { + my $offset = $range->{offset} // 0; + my $count = $range->{count}; + # Convert count/offset in start/end + if ($offset > 0) { + $offset -= ($count < 0); + } elsif ($offset < 0) { + $offset = $#$data + ($count > 0) + $offset; + } else { + $offset = $#$data if $count < 0; + } + $start = $end = $offset; + $start += $count+1 if $count < 0; + $end += $count-1 if $count > 0; + # Check limits + $start = 0 if $start < 0; + return if $start > $#$data; + $end = $#$data if $end > $#$data; + return if $end < 0; + $end = $start if $end < $start; + return [ @{$data}[$start .. $end] ]; + } + + ## no critic (ControlStructures::ProhibitUntilBlocks) + my @result; + my $include = 1; + $include = 0 if defined($range->{to}) or defined($range->{until}); + foreach my $entry (@{$data}) { + my $v = $entry->get_version(); + $include = 1 if defined($range->{to}) and $v eq $range->{to}; + last if defined($range->{since}) and $v eq $range->{since}; + + push @result, $entry if $include; + + $include = 1 if defined($range->{until}) and $v eq $range->{until}; + last if defined($range->{from}) and $v eq $range->{from}; + } + ## use critic + + return \@result if scalar(@result); + return; +} + +=item $c->abort_early() + +Returns true if enough data have been parsed to be able to return all +entries selected by the range set at creation (or with set_options). + +=cut + +sub abort_early { + my $self = shift; + + my $data = $self->{data} or return; + my $r = $self->{range} or return; + my $count = $r->{count} // 0; + my $offset = $r->{offset} // 0; + + return if $self->_is_full_range($r); + return if $offset < 0 or $count < 0; + if (defined($r->{count})) { + if ($offset > 0) { + $offset -= ($count < 0); + } + my $start = my $end = $offset; + $end += $count-1 if $count > 0; + return $start < @{$data} > $end; + } + + return unless defined($r->{since}) or defined($r->{from}); + foreach my $entry (@{$data}) { + my $v = $entry->get_version(); + return 1 if defined($r->{since}) and $v eq $r->{since}; + return 1 if defined($r->{from}) and $v eq $r->{from}; + } + + return; +} + +=item $str = $c->output() + +=item "$c" + +Returns a string representation of the changelog (it's a concatenation of +the string representation of the individual changelog entries). + +=item $c->output($fh) + +Output the changelog to the given filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + my $str = ''; + foreach my $entry (@{$self}) { + my $text = $entry->output(); + print { $fh } $text if defined $fh; + $str .= $text if defined wantarray; + } + my $text = $self->get_unparsed_tail(); + if (defined $text) { + print { $fh } $text if defined $fh; + $str .= $text if defined wantarray; + } + return $str; +} + +=item $c->save($filename) + +Save the changelog in the given file. + +=cut + +our ( @URGENCIES, %URGENCIES ); +BEGIN { + @URGENCIES = qw( + low + medium + high + critical + emergency + ); + my $i = 1; + %URGENCIES = map { $_ => $i++ } @URGENCIES; +} + +sub _format_dpkg { + my ($self, $range) = @_; + + my @data = $self->get_range($range) or return; + my $src = shift @data; + + my $c = Dpkg::Control::Changelog->new(); + $c->{Urgency} = $src->get_urgency() || 'unknown'; + $c->{Source} = $src->get_source() || 'unknown'; + $c->{Version} = $src->get_version() // 'unknown'; + $c->{Distribution} = join ' ', $src->get_distributions(); + $c->{Maintainer} = $src->get_maintainer() // ''; + $c->{Date} = $src->get_timestamp() // ''; + $c->{Timestamp} = $src->get_timepiece && $src->get_timepiece->epoch // ''; + $c->{Changes} = $src->get_dpkg_changes(); + + # handle optional fields + my $opts = $src->get_optional_fields(); + my %closes; + foreach my $f (keys %{$opts}) { + if ($f eq 'Urgency') { + # Already handled. + } elsif ($f eq 'Closes') { + $closes{$_} = 1 foreach (split(/\s+/, $opts->{Closes})); + } else { + field_transfer_single($opts, $c, $f); + } + } + + foreach my $bin (@data) { + my $oldurg = $c->{Urgency} // ''; + my $oldurgn = $URGENCIES{$c->{Urgency}} // -1; + my $newurg = $bin->get_urgency() // ''; + my $newurgn = $URGENCIES{$newurg} // -1; + $c->{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg; + $c->{Changes} .= "\n" . $bin->get_dpkg_changes(); + + # handle optional fields + $opts = $bin->get_optional_fields(); + foreach my $f (keys %{$opts}) { + if ($f eq 'Closes') { + $closes{$_} = 1 foreach (split(/\s+/, $opts->{Closes})); + } elsif (not exists $c->{$f}) { + # Don't overwrite an existing field + field_transfer_single($opts, $c, $f); + } + } + } + + if (scalar keys %closes) { + $c->{Closes} = join ' ', sort { $a <=> $b } keys %closes; + } + run_vendor_hook('post-process-changelog-entry', $c); + + return $c; +} + +sub _format_rfc822 { + my ($self, $range) = @_; + + my @data = $self->get_range($range) or return; + my @ctrl; + + foreach my $entry (@data) { + my $c = Dpkg::Control::Changelog->new(); + $c->{Urgency} = $entry->get_urgency() || 'unknown'; + $c->{Source} = $entry->get_source() || 'unknown'; + $c->{Version} = $entry->get_version() // 'unknown'; + $c->{Distribution} = join ' ', $entry->get_distributions(); + $c->{Maintainer} = $entry->get_maintainer() // ''; + $c->{Date} = $entry->get_timestamp() // ''; + $c->{Timestamp} = $entry->get_timepiece && $entry->get_timepiece->epoch // ''; + $c->{Changes} = $entry->get_dpkg_changes(); + + # handle optional fields + my $opts = $entry->get_optional_fields(); + foreach my $f (keys %{$opts}) { + field_transfer_single($opts, $c, $f) unless exists $c->{$f}; + } + + run_vendor_hook('post-process-changelog-entry', $c); + + push @ctrl, $c; + } + + return @ctrl; +} + +=item $control = $c->format_range($format, $range) + +Formats the changelog into L<Dpkg::Control::Changelog> objects representing +the entries selected by the optional range specifier (see L</RANGE SELECTION> +for details). In scalar context returns a L<Dpkg::Index> object containing +the selected entries, in list context returns an array of +L<Dpkg::Control::Changelog> objects. + +With format B<dpkg> the returned L<Dpkg::Control::Changelog> object is +coalesced from the entries in the changelog that are part of the range +requested, with the fields described below, but considering that +"selected entry" means the first entry of the selected range. + +With format B<rfc822> each returned L<Dpkg::Control::Changelog> objects +represents one entry in the changelog that is part of the range requested, +with the fields described below, but considering that "selected entry" +means for each entry. + +The different formats return undef if no entries are matched. The following +fields are contained in the object(s) returned: + +=over 4 + +=item Source + +package name (selected entry) + +=item Version + +packages' version (selected entry) + +=item Distribution + +target distribution (selected entry) + +=item Urgency + +urgency (highest of all entries in range) + +=item Maintainer + +person that created the (selected) entry + +=item Date + +date of the (selected) entry + +=item Timestamp + +date of the (selected) entry as a timestamp in seconds since the epoch + +=item Closes + +bugs closed by the (selected) entry/entries, sorted by bug number + +=item Changes + +content of the (selected) entry/entries + +=back + +=cut + +sub format_range { + my ($self, $format, $range) = @_; + + my @ctrl; + + if ($format eq 'dpkg') { + @ctrl = $self->_format_dpkg($range); + } elsif ($format eq 'rfc822') { + @ctrl = $self->_format_rfc822($range); + } else { + croak "unknown changelog output format $format"; + } + + if (wantarray) { + return @ctrl; + } else { + my $index = Dpkg::Index->new(type => CTRL_CHANGELOG); + + foreach my $c (@ctrl) { + $index->add($c); + } + + return $index; + } +} + +=back + +=head1 RANGE SELECTION + +A range selection is described by a hash reference where +the allowed keys and values are described below. + +The following options take a version number as value. + +=over 4 + +=item since + +Causes changelog information from all versions strictly +later than B<version> to be used. + +=item until + +Causes changelog information from all versions strictly +earlier than B<version> to be used. + +=item from + +Similar to C<since> but also includes the information for the +specified B<version> itself. + +=item to + +Similar to C<until> but also includes the information for the +specified B<version> itself. + +=back + +The following options don't take version numbers as values: + +=over 4 + +=item all + +If set to a true value, all entries of the changelog are returned, +this overrides all other options. + +=item count + +Expects a signed integer as value. Returns C<value> entries from the +top of the changelog if set to a positive integer, and C<abs(value)> +entries from the tail if set to a negative integer. + +=item offset + +Expects a signed integer as value. Changes the starting point for +C<count>, either counted from the top (positive integer) or from +the tail (negative integer). C<offset> has no effect if C<count> +wasn't given as well. + +=back + +Some examples for the above options. Imagine an example changelog with +entries for the versions 1.2, 1.3, 2.0, 2.1, 2.2, 3.0 and 3.1. + + Range Included entries + ----- ---------------- + since => '2.0' 3.1, 3.0, 2.2 + until => '2.0' 1.3, 1.2 + from => '2.0' 3.1, 3.0, 2.2, 2.1, 2.0 + to => '2.0' 2.0, 1.3, 1.2 + count => 2 3.1, 3.0 + count => -2 1.3, 1.2 + count => 3, offset => 2 2.2, 2.1, 2.0 + count => 2, offset => -3 2.0, 1.3 + count => -2, offset => 3 3.0, 2.2 + count => -2, offset => -3 2.2, 2.1 + +Any combination of one option of C<since> and C<from> and one of +C<until> and C<to> returns the intersection of the two results +with only one of the options specified. + +=head1 CHANGES + +=head2 Version 2.00 (dpkg 1.20.0) + +Remove methods: $c->dpkg(), $c->rfc822(). + +=head2 Version 1.01 (dpkg 1.18.8) + +New method: $c->format_range(). + +Deprecated methods: $c->dpkg(), $c->rfc822(). + +New field Timestamp in output formats. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut +1; diff --git a/scripts/Dpkg/Changelog/Debian.pm b/scripts/Dpkg/Changelog/Debian.pm new file mode 100644 index 0000000..e7dd7c4 --- /dev/null +++ b/scripts/Dpkg/Changelog/Debian.pm @@ -0,0 +1,269 @@ +# Copyright © 1996 Ian Jackson +# Copyright © 2005 Frank Lichtenheld <frank@lichtenheld.de> +# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2012-2017 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Changelog::Debian - parse Debian changelogs + +=head1 DESCRIPTION + +This class represents a Debian changelog file as an array of changelog +entries (L<Dpkg::Changelog::Entry::Debian>). +It implements the generic interface L<Dpkg::Changelog>. +Only methods specific to this implementation are described below, +the rest are inherited. + +Dpkg::Changelog::Debian parses Debian changelogs as described in +L<deb-changelog(5)>. + +The parser tries to ignore most cruft like # or /* */ style comments, +RCS keywords, Vim modelines, Emacs local variables and stuff from +older changelogs with other formats at the end of the file. +NOTE: most of these are ignored silently currently, there is no +parser error issued for them. This should become configurable in the +future. + +=cut + +package Dpkg::Changelog::Debian 1.00; + +use strict; +use warnings; + +use Dpkg::Gettext; +use Dpkg::File; +use Dpkg::Changelog; +use Dpkg::Changelog::Entry::Debian qw(match_header match_trailer); + +use parent qw(Dpkg::Changelog); + +use constant { + FIRST_HEADING => g_('first heading'), + NEXT_OR_EOF => g_('next heading or end of file'), + START_CHANGES => g_('start of change data'), + CHANGES_OR_TRAILER => g_('more change data or trailer'), +}; + +my $ancient_delimiter_re = qr{ + ^ + (?: # Ancient GNU style changelog entry with expanded date + (?: + \w+\s+ # Day of week (abbreviated) + \w+\s+ # Month name (abbreviated) + \d{1,2} # Day of month + \Q \E + \d{1,2}:\d{1,2}:\d{1,2}\s+ # Time + [\w\s]* # Timezone + \d{4} # Year + ) + \s+ + (?:.*) # Maintainer name + \s+ + [<\(] + (?:.*) # Maintainer email + [\)>] + | # Old GNU style changelog entry with expanded date + (?: + \w+\s+ # Day of week (abbreviated) + \w+\s+ # Month name (abbreviated) + \d{1,2},?\s* # Day of month + \d{4} # Year + ) + \s+ + (?:.*) # Maintainer name + \s+ + [<\(] + (?:.*) # Maintainer email + [\)>] + | # Ancient changelog header w/o key=value options + (?:\w[-+0-9a-z.]*) # Package name + \Q \E + \( + (?:[^\(\) \t]+) # Package version + \) + \;? + | # Ancient changelog header + (?:[\w.+-]+) # Package name + [- ] + (?:\S+) # Package version + \ Debian + \ (?:\S+) # Package revision + | + Changes\ from\ version\ (?:.*)\ to\ (?:.*): + | + Changes\ for\ [\w.+-]+-[\w.+-]+:?\s*$ + | + Old\ Changelog:\s*$ + | + (?:\d+:)? + \w[\w.+~-]*:? + \s*$ + ) +}xi; + +=head1 METHODS + +=over 4 + +=item $count = $c->parse($fh, $description) + +Read the filehandle and parse a Debian changelog in it, to store the entries +as an array of L<Dpkg::Changelog::Entry::Debian> objects. +Any previous entries in the object are reset before parsing new data. + +Returns the number of changelog entries that have been parsed with success. + +=cut + +sub parse { + my ($self, $fh, $file) = @_; + $file = $self->{reportfile} if exists $self->{reportfile}; + + $self->reset_parse_errors; + + $self->{data} = []; + $self->set_unparsed_tail(undef); + + my $expect = FIRST_HEADING; + my $entry = Dpkg::Changelog::Entry::Debian->new(); + my @blanklines = (); + # To make version unique, for example for using as id. + my $unknowncounter = 1; + local $_; + + while (<$fh>) { + chomp; + if (match_header($_)) { + unless ($expect eq FIRST_HEADING || $expect eq NEXT_OR_EOF) { + $self->parse_error($file, $., + sprintf(g_('found start of entry where expected %s'), + $expect), "$_"); + } + unless ($entry->is_empty) { + push @{$self->{data}}, $entry; + $entry = Dpkg::Changelog::Entry::Debian->new(); + last if $self->abort_early(); + } + $entry->set_part('header', $_); + foreach my $error ($entry->parse_header()) { + $self->parse_error($file, $., $error, $_); + } + $expect = START_CHANGES; + @blanklines = (); + } elsif (m/^(?:;;\s*)?Local variables:/io) { + # Save any trailing Emacs variables at end of file. + $self->set_unparsed_tail("$_\n" . (file_slurp($fh) // '')); + last; + } elsif (m/^vim:/io) { + # Save any trailing Vim modelines at end of file. + $self->set_unparsed_tail("$_\n" . (file_slurp($fh) // '')); + last; + } elsif (m/^\$\w+:.*\$/o) { + next; # skip stuff that look like a RCS keyword + } elsif (m/^\# /o) { + next; # skip comments, even that's not supported + } elsif (m{^/\*.*\*/}o) { + next; # more comments + } elsif (m/$ancient_delimiter_re/) { + # save entries on old changelog format verbatim + # we assume the rest of the file will be in old format once we + # hit it for the first time + $self->set_unparsed_tail("$_\n" . file_slurp($fh)); + } elsif (m/^\S/) { + $self->parse_error($file, $., g_('badly formatted heading line'), "$_"); + } elsif (match_trailer($_)) { + unless ($expect eq CHANGES_OR_TRAILER) { + $self->parse_error($file, $., + sprintf(g_('found trailer where expected %s'), $expect), "$_"); + } + $entry->set_part('trailer', $_); + $entry->extend_part('blank_after_changes', [ @blanklines ]); + @blanklines = (); + foreach my $error ($entry->parse_trailer()) { + $self->parse_error($file, $., $error, $_); + } + $expect = NEXT_OR_EOF; + } elsif (m/^ \-\-/) { + $self->parse_error($file, $., g_('badly formatted trailer line'), "$_"); + } elsif (m/^\s{2,}(?:\S)/) { + unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) { + $self->parse_error($file, $., sprintf(g_('found change data' . + ' where expected %s'), $expect), "$_"); + if ($expect eq NEXT_OR_EOF and not $entry->is_empty) { + # lets assume we have missed the actual header line + push @{$self->{data}}, $entry; + $entry = Dpkg::Changelog::Entry::Debian->new(); + $entry->set_part('header', 'unknown (unknown' . ($unknowncounter++) . ') unknown; urgency=unknown'); + } + } + # Keep raw changes + $entry->extend_part('changes', [ @blanklines, $_ ]); + @blanklines = (); + $expect = CHANGES_OR_TRAILER; + } elsif (!m/\S/) { + if ($expect eq START_CHANGES) { + $entry->extend_part('blank_after_header', $_); + next; + } elsif ($expect eq NEXT_OR_EOF) { + $entry->extend_part('blank_after_trailer', $_); + next; + } elsif ($expect ne CHANGES_OR_TRAILER) { + $self->parse_error($file, $., + sprintf(g_('found blank line where expected %s'), $expect)); + } + push @blanklines, $_; + } else { + $self->parse_error($file, $., g_('unrecognized line'), "$_"); + unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) { + # lets assume change data if we expected it + $entry->extend_part('changes', [ @blanklines, $_]); + @blanklines = (); + $expect = CHANGES_OR_TRAILER; + } + } + } + + unless ($expect eq NEXT_OR_EOF) { + $self->parse_error($file, $., + sprintf(g_('found end of file where expected %s'), + $expect)); + } + unless ($entry->is_empty) { + push @{$self->{data}}, $entry; + } + + return scalar @{$self->{data}}; +} + +1; + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=head1 SEE ALSO + +L<Dpkg::Changelog>. + +=cut diff --git a/scripts/Dpkg/Changelog/Entry.pm b/scripts/Dpkg/Changelog/Entry.pm new file mode 100644 index 0000000..e572909 --- /dev/null +++ b/scripts/Dpkg/Changelog/Entry.pm @@ -0,0 +1,324 @@ +# Copyright © 2009 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Changelog::Entry - represents a changelog entry + +=head1 DESCRIPTION + +This class represents a changelog entry. It is composed +of a set of lines with specific purpose: a header line, changes lines, a +trailer line. Blank lines can be between those kind of lines. + +=cut + +package Dpkg::Changelog::Entry 1.01; + +use strict; +use warnings; + +use Carp; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control::Changelog; + +use overload + '""' => \&output, + 'eq' => sub { defined($_[1]) and "$_[0]" eq "$_[1]" }, + fallback => 1; + +=head1 METHODS + +=over 4 + +=item $entry = Dpkg::Changelog::Entry->new() + +Creates a new object. It doesn't represent a real changelog entry +until one has been successfully parsed or built from scratch. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + + my $self = { + header => undef, + changes => [], + trailer => undef, + blank_after_header => [], + blank_after_changes => [], + blank_after_trailer => [], + }; + bless $self, $class; + return $self; +} + +=item $str = $entry->output() + +=item "$entry" + +Get a string representation of the changelog entry. + +=item $entry->output($fh) + +Print the string representation of the changelog entry to a +filehandle. + +=cut + +sub _format_output_block { + my $lines = shift; + return join('', map { $_ . "\n" } @{$lines}); +} + +sub output { + my ($self, $fh) = @_; + my $str = ''; + $str .= $self->{header} . "\n" if defined($self->{header}); + $str .= _format_output_block($self->{blank_after_header}); + $str .= _format_output_block($self->{changes}); + $str .= _format_output_block($self->{blank_after_changes}); + $str .= $self->{trailer} . "\n" if defined($self->{trailer}); + $str .= _format_output_block($self->{blank_after_trailer}); + print { $fh } $str if defined $fh; + return $str; +} + +=item $entry->get_part($part) + +Return either a string (for a single line) or an array ref (for multiple +lines) corresponding to the requested part. $part can be +"header, "changes", "trailer", "blank_after_header", +"blank_after_changes", "blank_after_trailer". + +=cut + +sub get_part { + my ($self, $part) = @_; + croak "invalid part of changelog entry: $part" unless exists $self->{$part}; + return $self->{$part}; +} + +=item $entry->set_part($part, $value) + +Set the value of the corresponding part. $value can be a string +or an array ref. + +=cut + +sub set_part { + my ($self, $part, $value) = @_; + croak "invalid part of changelog entry: $part" unless exists $self->{$part}; + if (ref($self->{$part})) { + if (ref($value)) { + $self->{$part} = $value; + } else { + $self->{$part} = [ $value ]; + } + } else { + $self->{$part} = $value; + } +} + +=item $entry->extend_part($part, $value) + +Concatenate $value at the end of the part. If the part is already a +multi-line value, $value is added as a new line otherwise it's +concatenated at the end of the current line. + +=cut + +sub extend_part { + my ($self, $part, $value, @rest) = @_; + croak "invalid part of changelog entry: $part" unless exists $self->{$part}; + if (ref($self->{$part})) { + if (ref($value)) { + push @{$self->{$part}}, @$value; + } else { + push @{$self->{$part}}, $value; + } + } else { + if (defined($self->{$part})) { + if (ref($value)) { + $self->{$part} = [ $self->{$part}, @$value ]; + } else { + $self->{$part} .= $value; + } + } else { + $self->{$part} = $value; + } + } +} + +=item $is_empty = $entry->is_empty() + +Returns 1 if the changelog entry doesn't contain anything at all. +Returns 0 as soon as it contains something in any of its non-blank +parts. + +=cut + +sub is_empty { + my $self = shift; + return !(defined($self->{header}) || defined($self->{trailer}) || + scalar(@{$self->{changes}})); +} + +=item $entry->normalize() + +Normalize the content. Strip whitespaces at end of lines, use a single +empty line to separate each part. + +=cut + +sub normalize { + my $self = shift; + if (defined($self->{header})) { + $self->{header} =~ s/\s+$//g; + $self->{blank_after_header} = ['']; + } else { + $self->{blank_after_header} = []; + } + if (scalar(@{$self->{changes}})) { + s/\s+$//g foreach @{$self->{changes}}; + $self->{blank_after_changes} = ['']; + } else { + $self->{blank_after_changes} = []; + } + if (defined($self->{trailer})) { + $self->{trailer} =~ s/\s+$//g; + $self->{blank_after_trailer} = ['']; + } else { + $self->{blank_after_trailer} = []; + } +} + +=item $src = $entry->get_source() + +Return the name of the source package associated to the changelog entry. + +=cut + +sub get_source { + return; +} + +=item $ver = $entry->get_version() + +Return the version associated to the changelog entry. + +=cut + +sub get_version { + return; +} + +=item @dists = $entry->get_distributions() + +Return a list of target distributions for this version. + +=cut + +sub get_distributions { + return; +} + +=item $ctrl = $entry->get_optional_fields() + +Return a set of optional fields exposed by the changelog entry. +It always returns a L<Dpkg::Control> object (possibly empty though). + +=cut + +sub get_optional_fields { + return Dpkg::Control::Changelog->new(); +} + +=item $urgency = $entry->get_urgency() + +Return the urgency of the associated upload. + +=cut + +sub get_urgency { + return; +} + +=item $maint = $entry->get_maintainer() + +Return the string identifying the person who signed this changelog entry. + +=cut + +sub get_maintainer { + return; +} + +=item $time = $entry->get_timestamp() + +Return the timestamp of the changelog entry. + +=cut + +sub get_timestamp { + return; +} + +=item $time = $entry->get_timepiece() + +Return the timestamp of the changelog entry as a L<Time::Piece> object. + +This function might return undef if there was no timestamp. + +=cut + +sub get_timepiece { + return; +} + +=item $str = $entry->get_dpkg_changes() + +Returns a string that is suitable for usage in a C<Changes> field +in the output format of C<dpkg-parsechangelog>. + +=cut + +sub get_dpkg_changes { + my $self = shift; + my $header = $self->get_part('header') // ''; + $header =~ s/\s+$//; + return "\n$header\n\n" . join("\n", @{$self->get_part('changes')}); +} + +=back + +=head1 CHANGES + +=head2 Version 1.01 (dpkg 1.18.8) + +New method: $entry->get_timepiece(). + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Changelog/Entry/Debian.pm b/scripts/Dpkg/Changelog/Entry/Debian.pm new file mode 100644 index 0000000..c646fcc --- /dev/null +++ b/scripts/Dpkg/Changelog/Entry/Debian.pm @@ -0,0 +1,462 @@ +# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2012-2013 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Changelog::Entry::Debian - represents a Debian changelog entry + +=head1 DESCRIPTION + +This class represents a Debian changelog entry. +It implements the generic interface L<Dpkg::Changelog::Entry>. +Only functions specific to this implementation are described below, +the rest are inherited. + +=cut + +package Dpkg::Changelog::Entry::Debian 2.00; + +use strict; +use warnings; + +our @EXPORT_OK = qw( + match_header + match_trailer + find_closes +); + +use Exporter qw(import); +use Time::Piece; + +use Dpkg::Gettext; +use Dpkg::Control::Fields; +use Dpkg::Control::Changelog; +use Dpkg::Changelog::Entry; +use Dpkg::Version; + +use parent qw(Dpkg::Changelog::Entry); + +my $name_chars = qr/[-+0-9a-z.]/i; + +# The matched content is the source package name ($1), the version ($2), +# the target distributions ($3) and the options on the rest of the line ($4). +my $regex_header = qr{ + ^ + (\w$name_chars*) # Package name + \ \(([^\(\) \t]+)\) # Package version + ((?:\s+$name_chars+)+) # Target distribution + \; # Separator + (.*?) # Key=Value options + \s*$ # Trailing space +}xi; + +# The matched content is the maintainer name ($1), its email ($2), +# some blanks ($3) and the timestamp ($4), which is decomposed into +# day of week ($6), date-time ($7) and this into month name ($8). +my $regex_trailer = qr< + ^ + \ \-\- # Trailer marker + \ (.*) # Maintainer name + \ \<(.*)\> # Maintainer email + (\ \ ?) # Blanks + ( + ((\w+)\,\s*)? # Day of week (abbreviated) + ( + \d{1,2}\s+ # Day of month + (\w+)\s+ # Month name (abbreviated) + \d{4}\s+ # Year + \d{1,2}:\d\d:\d\d\s+[-+]\d{4} # ISO 8601 date + ) + ) + \s*$ # Trailing space +>xo; + +my %week_day = map { $_ => 1 } qw(Mon Tue Wed Thu Fri Sat Sun); +my @month_abbrev = qw( + Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec +); +my %month_abbrev = map { $_ => 1 } @month_abbrev; +my @month_name = qw( + January February March April May June July + August September October November December +); +my %month_name = map { $month_name[$_] => $month_abbrev[$_] } 0 .. 11; + +=head1 METHODS + +=over 4 + +=item @items = $entry->get_change_items() + +Return a list of change items. Each item contains at least one line. +A change line starting with an asterisk denotes the start of a new item. +Any change line like "C<[ Raphaël Hertzog ]>" is treated like an item of its +own even if it starts a set of items attributed to this person (the +following line necessarily starts a new item). + +=cut + +sub get_change_items { + my $self = shift; + my (@items, @blanks, $item); + foreach my $line (@{$self->get_part('changes')}) { + if ($line =~ /^\s*\*/) { + push @items, $item if defined $item; + $item = "$line\n"; + } elsif ($line =~ /^\s*\[\s[^\]]+\s\]\s*$/) { + push @items, $item if defined $item; + push @items, "$line\n"; + $item = undef; + @blanks = (); + } elsif ($line =~ /^\s*$/) { + push @blanks, "$line\n"; + } else { + if (defined $item) { + $item .= "@blanks$line\n"; + } else { + $item = "$line\n"; + } + @blanks = (); + } + } + push @items, $item if defined $item; + return @items; +} + +=item @errors = $entry->parse_header() + +=item @errors = $entry->parse_trailer() + +Return a list of errors. Each item in the list is an error message +describing the problem. If the empty list is returned, no errors +have been found. + +=cut + +sub parse_header { + my $self = shift; + my @errors; + if (defined($self->{header}) and $self->{header} =~ $regex_header) { + $self->{header_source} = $1; + + my $version = Dpkg::Version->new($2); + my ($ok, $msg) = version_check($version); + if ($ok) { + $self->{header_version} = $version; + } else { + push @errors, sprintf(g_("version '%s' is invalid: %s"), $version, $msg); + } + + @{$self->{header_dists}} = split ' ', $3; + + my $options = $4; + $options =~ s/^\s+//; + my $c = Dpkg::Control::Changelog->new(); + foreach my $opt (split(/\s*,\s*/, $options)) { + unless ($opt =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i) { + push @errors, sprintf(g_("bad key-value after ';': '%s'"), $opt); + next; + } + ## no critic (RegularExpressions::ProhibitCaptureWithoutTest) + my ($k, $v) = (field_capitalize($1), $2); + if (exists $c->{$k}) { + push @errors, sprintf(g_('repeated key-value %s'), $k); + } else { + $c->{$k} = $v; + } + if ($k eq 'Urgency') { + push @errors, sprintf(g_('badly formatted urgency value: %s'), $v) + unless ($v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i); + } elsif ($k eq 'Binary-Only') { + push @errors, sprintf(g_('bad binary-only value: %s'), $v) + unless ($v eq 'yes'); + } elsif ($k =~ m/^X[BCS]+-/i) { + } else { + push @errors, sprintf(g_('unknown key-value %s'), $k); + } + } + $self->{header_fields} = $c; + } else { + push @errors, g_("the header doesn't match the expected regex"); + } + return @errors; +} + +sub parse_trailer { + my $self = shift; + my @errors; + if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) { + $self->{trailer_maintainer} = "$1 <$2>"; + + if ($3 ne ' ') { + push @errors, g_('badly formatted trailer line'); + } + + # Validate the week day. Date::Parse used to ignore it, but Time::Piece + # is much more strict and it does not gracefully handle bogus values. + if (defined $5 and not exists $week_day{$6}) { + push @errors, sprintf(g_('ignoring invalid week day \'%s\''), $6); + } + + # Ignore the week day ('%a, '), as we have validated it above. + local $ENV{LC_ALL} = 'C'; + eval { + my $tp = Time::Piece->strptime($7, '%d %b %Y %T %z'); + $self->{trailer_timepiece} = $tp; + } or do { + # Validate the month. Date::Parse used to accept both abbreviated + # and full months, but Time::Piece strptime() implementation only + # matches the abbreviated one with %b, which is what we want anyway. + if (not exists $month_abbrev{$8}) { + # We have to nest the conditionals because May is the same in + # full and abbreviated forms! + if (exists $month_name{$8}) { + push @errors, sprintf(g_('uses full \'%s\' instead of abbreviated month name \'%s\''), + $8, $month_name{$8}); + } else { + push @errors, sprintf(g_('invalid abbreviated month name \'%s\''), $8); + } + } + push @errors, sprintf(g_("cannot parse non-conformant date '%s'"), $7); + }; + $self->{trailer_timestamp_date} = $4; + } else { + push @errors, g_("the trailer doesn't match the expected regex"); + } + return @errors; +} + +=item $entry->normalize() + +Normalize the content. Strip whitespaces at end of lines, use a single +empty line to separate each part. + +=cut + +sub normalize { + my $self = shift; + $self->SUPER::normalize(); + #XXX: recreate header/trailer +} + +=item $src = $entry->get_source() + +Return the name of the source package associated to the changelog entry. + +=cut + +sub get_source { + my $self = shift; + + return $self->{header_source}; +} + +=item $ver = $entry->get_version() + +Return the version associated to the changelog entry. + +=cut + +sub get_version { + my $self = shift; + + return $self->{header_version}; +} + +=item @dists = $entry->get_distributions() + +Return a list of target distributions for this version. + +=cut + +sub get_distributions { + my $self = shift; + + if (defined $self->{header_dists}) { + return @{$self->{header_dists}} if wantarray; + return $self->{header_dists}[0]; + } + return; +} + +=item $ctrl = $entry->get_optional_fields() + +Return a set of optional fields exposed by the changelog entry. +It always returns a L<Dpkg::Control> object (possibly empty though). + +=cut + +sub get_optional_fields { + my $self = shift; + my $c; + + if (defined $self->{header_fields}) { + $c = $self->{header_fields}; + } else { + $c = Dpkg::Control::Changelog->new(); + } + + my @closes = find_closes(join("\n", @{$self->{changes}})); + if (@closes) { + $c->{Closes} = join ' ', @closes; + } + + return $c; +} + +=item $urgency = $entry->get_urgency() + +Return the urgency of the associated upload. + +=cut + +sub get_urgency { + my $self = shift; + my $c = $self->get_optional_fields(); + if (exists $c->{Urgency}) { + $c->{Urgency} =~ s/\s.*$//; + return lc $c->{Urgency}; + } + return; +} + +=item $maint = $entry->get_maintainer() + +Return the string identifying the person who signed this changelog entry. + +=cut + +sub get_maintainer { + my $self = shift; + + return $self->{trailer_maintainer}; +} + +=item $time = $entry->get_timestamp() + +Return the timestamp of the changelog entry. + +=cut + +sub get_timestamp { + my $self = shift; + + return $self->{trailer_timestamp_date}; +} + +=item $time = $entry->get_timepiece() + +Return the timestamp of the changelog entry as a L<Time::Piece> object. + +This function might return undef if there was no timestamp. + +=cut + +sub get_timepiece { + my $self = shift; + + return $self->{trailer_timepiece}; +} + +=back + +=head1 UTILITY FUNCTIONS + +=over 4 + +=item $bool = match_header($line) + +Checks if the line matches a valid changelog header line. + +=cut + +sub match_header { + my $line = shift; + + return $line =~ /$regex_header/; +} + +=item $bool = match_trailer($line) + +Checks if the line matches a valid changelog trailing line. + +=cut + +sub match_trailer { + my $line = shift; + + return $line =~ /$regex_trailer/; +} + +=item @closed_bugs = find_closes($changes) + +Takes one string as argument and finds "Closes: #123456, #654321" statements +as supported by the Debian Archive software in it. Returns all closed bug +numbers in an array. + +=cut + +sub find_closes { + my $changes = shift; + my %closes; + + while ($changes && ($changes =~ m{ + closes:\s* + (?:bug)?\#?\s?\d+ + (?:,\s*(?:bug)?\#?\s?\d+)* + }pigx)) { + $closes{$_} = 1 foreach (${^MATCH} =~ /\#?\s?(\d+)/g); + } + + my @closes = sort { $a <=> $b } keys %closes; + return @closes; +} + +=back + +=head1 CHANGES + +=head2 Version 2.00 (dpkg 1.20.0) + +Remove methods: $entry->check_header(), $entry->check_trailer(). + +Hide variables: $regex_header, $regex_trailer. + +=head2 Version 1.03 (dpkg 1.18.8) + +New methods: $entry->get_timepiece(). + +=head2 Version 1.02 (dpkg 1.18.5) + +New methods: $entry->parse_header(), $entry->parse_trailer(). + +Deprecated methods: $entry->check_header(), $entry->check_trailer(). + +=head2 Version 1.01 (dpkg 1.17.2) + +New functions: match_header(), match_trailer() + +Deprecated variables: $regex_header, $regex_trailer + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Changelog/Parse.pm b/scripts/Dpkg/Changelog/Parse.pm new file mode 100644 index 0000000..9b0afb7 --- /dev/null +++ b/scripts/Dpkg/Changelog/Parse.pm @@ -0,0 +1,195 @@ +# Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de> +# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2010, 2012-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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Changelog::Parse - generic changelog parser for dpkg-parsechangelog + +=head1 DESCRIPTION + +This module provides a set of functions which reproduce all the features +of dpkg-parsechangelog. + +=cut + +package Dpkg::Changelog::Parse 2.01; + +use strict; +use warnings; + +our @EXPORT = qw( + changelog_parse +); + +use Exporter qw(import); +use List::Util qw(none); + +use Dpkg (); +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control::Changelog; + +sub _changelog_detect_format { + my $file = shift; + my $format = 'debian'; + + # Extract the format from the changelog file if possible + if ($file ne '-') { + local $_; + + open my $format_fh, '<', $file + or syserr(g_('cannot open file %s'), $file); + if (-s $format_fh > 4096) { + seek $format_fh, -4096, 2 + or syserr(g_('cannot seek into file %s'), $file); + } + while (<$format_fh>) { + $format = $1 if m/\schangelog-format:\s+([0-9a-z]+)\W/; + } + close $format_fh; + } + + return $format; +} + +=head1 FUNCTIONS + +=over 4 + +=item $fields = changelog_parse(%opt) + +This function will parse a changelog. In list context, it returns as many +L<Dpkg::Control> objects as the parser did create. In scalar context, it will +return only the first one. If the parser did not return any data, it will +return an empty list in list context or undef on scalar context. If the +parser failed, it will die. Any parse errors will be printed as warnings +on standard error, but this can be disabled by passing $opt{verbose} to 0. + +The changelog file that is parsed is F<debian/changelog> by default but it +can be overridden with $opt{file}. The changelog name used in output messages +can be specified with $opt{label}, otherwise it will default to $opt{file}. +The default output format is "dpkg" but it can be overridden with $opt{format}. + +The parsing itself is done by a parser module (searched in the standard +perl library directories. That module is named according to the format that +it is able to parse, with the name capitalized. By default it is either +L<Dpkg::Changelog::Debian> (from the "debian" format) or the format name looked +up in the 40 last lines of the changelog itself (extracted with this perl +regular expression "\schangelog-format:\s+([0-9a-z]+)\W"). But it can be +overridden with $opt{changelogformat}. + +If $opt{compression} is false, the file will be loaded without compression +support, otherwise by default compression support is disabled if the file +is the default. + +All the other keys in %opt are forwarded to the parser module constructor. + +=cut + +sub changelog_parse { + my (%options) = @_; + + $options{verbose} //= 1; + $options{file} //= 'debian/changelog'; + $options{label} //= $options{file}; + $options{changelogformat} //= _changelog_detect_format($options{file}); + $options{format} //= 'dpkg'; + $options{compression} //= $options{file} ne 'debian/changelog'; + + my @range_opts = qw(since until from to offset count reverse all); + $options{all} = 1 if exists $options{all}; + if (none { defined $options{$_} } @range_opts) { + $options{count} = 1; + } + my $range; + foreach my $opt (@range_opts) { + $range->{$opt} = $options{$opt} if exists $options{$opt}; + } + + # Find the right changelog parser. + my $format = ucfirst lc $options{changelogformat}; + my $changes; + eval qq{ + require Dpkg::Changelog::$format; + \$changes = Dpkg::Changelog::$format->new(); + }; + error(g_('changelog format %s is unknown: %s'), $format, $@) if $@; + error(g_('changelog format %s is not a Dpkg::Changelog class'), $format) + unless $changes->isa('Dpkg::Changelog'); + $changes->set_options(reportfile => $options{label}, + verbose => $options{verbose}, + range => $range); + + # Load and parse the changelog. + $changes->load($options{file}, compression => $options{compression}) + or error(g_('fatal error occurred while parsing %s'), $options{file}); + + # Get the output into several Dpkg::Control objects. + my @res; + if ($options{format} eq 'dpkg') { + push @res, $changes->format_range('dpkg', $range); + } elsif ($options{format} eq 'rfc822') { + push @res, $changes->format_range('rfc822', $range); + } else { + error(g_('unknown output format %s'), $options{format}); + } + + if (wantarray) { + return @res; + } else { + return $res[0] if @res; + return; + } +} + +=back + +=head1 CHANGES + +=head2 Version 2.01 (dpkg 1.20.6) + +New option: 'verbose' in changelog_parse(). + +=head2 Version 2.00 (dpkg 1.20.0) + +Remove functions: changelog_parse_debian(), changelog_parse_plugin(). + +Remove warnings: For options 'forceplugin', 'libdir'. + +=head2 Version 1.03 (dpkg 1.19.0) + +New option: 'compression' in changelog_parse(). + +=head2 Version 1.02 (dpkg 1.18.8) + +Deprecated functions: changelog_parse_debian(), changelog_parse_plugin(). + +Obsolete options: forceplugin, libdir. + +=head2 Version 1.01 (dpkg 1.18.2) + +New functions: changelog_parse_debian(), changelog_parse_plugin(). + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Checksums.pm b/scripts/Dpkg/Checksums.pm new file mode 100644 index 0000000..50b1651 --- /dev/null +++ b/scripts/Dpkg/Checksums.pm @@ -0,0 +1,432 @@ +# Copyright © 2008 Frank Lichtenheld <djpig@debian.org> +# Copyright © 2008, 2012-2015 Guillem Jover <guillem@debian.org> +# Copyright © 2010 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Checksums - generate and manipulate file checksums + +=head1 DESCRIPTION + +This module provides a class that can generate and manipulate +various file checksums as well as some methods to query information +about supported checksums. + +=cut + +package Dpkg::Checksums 1.04; + +use strict; +use warnings; + +our @EXPORT = qw( + checksums_is_supported + checksums_get_list + checksums_get_property +); + +use Exporter qw(import); +use Digest; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +=head1 FUNCTIONS + +=over 4 + +=cut + +my $CHECKSUMS = { + md5 => { + name => 'MD5', + regex => qr/[0-9a-f]{32}/, + strong => 0, + }, + sha1 => { + name => 'SHA-1', + regex => qr/[0-9a-f]{40}/, + strong => 0, + }, + sha256 => { + name => 'SHA-256', + regex => qr/[0-9a-f]{64}/, + strong => 1, + }, +}; + +=item @list = checksums_get_list() + +Returns the list of supported checksums algorithms. + +=cut + +sub checksums_get_list() { + my @list = sort keys %{$CHECKSUMS}; + return @list; +} + +=item $bool = checksums_is_supported($alg) + +Returns a boolean indicating whether the given checksum algorithm is +supported. The checksum algorithm is case-insensitive. + +=cut + +sub checksums_is_supported($) { + my $alg = shift; + return exists $CHECKSUMS->{lc($alg)}; +} + +=item $value = checksums_get_property($alg, $property) + +Returns the requested property of the checksum algorithm. Returns undef if +either the property or the checksum algorithm doesn't exist. Valid +properties currently include "name" (returns the name of the digest +algorithm), "regex" for the regular expression describing the common +string representation of the checksum, and "strong" for a boolean describing +whether the checksum algorithm is considered cryptographically strong. + +=cut + +sub checksums_get_property($$) { + my ($alg, $property) = @_; + + return unless checksums_is_supported($alg); + return $CHECKSUMS->{lc($alg)}{$property}; +} + +=back + +=head1 METHODS + +=over 4 + +=item $ck = Dpkg::Checksums->new() + +Create a new Dpkg::Checksums object. This object is able to store +the checksums of several files to later export them or verify them. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = {}; + bless $self, $class; + $self->reset(); + + return $self; +} + +=item $ck->reset() + +Forget about all checksums stored. The object is again in the same state +as if it was newly created. + +=cut + +sub reset { + my $self = shift; + + $self->{files} = []; + $self->{checksums} = {}; + $self->{size} = {}; +} + +=item $ck->add_from_file($filename, %opts) + +Add or verify checksums information for the file $filename. The file must +exists for the call to succeed. If you don't want the given filename to +appear when you later export the checksums you might want to set the "key" +option with the public name that you want to use. Also if you don't want +to generate all the checksums, you can pass an array reference of the +wanted checksums in the "checksums" option. + +It the object already contains checksums information associated the +filename (or key), it will error out if the newly computed information +does not match what's stored, and the caller did not request that it be +updated with the boolean "update" option. + +=cut + +sub add_from_file { + my ($self, $file, %opts) = @_; + my $key = exists $opts{key} ? $opts{key} : $file; + my @alg; + if (exists $opts{checksums}) { + push @alg, map { lc } @{$opts{checksums}}; + } else { + push @alg, checksums_get_list(); + } + + push @{$self->{files}}, $key unless exists $self->{size}{$key}; + (my @s = stat($file)) or syserr(g_('cannot fstat file %s'), $file); + if (not $opts{update} and exists $self->{size}{$key} and + $self->{size}{$key} != $s[7]) { + error(g_('file %s has size %u instead of expected %u'), + $file, $s[7], $self->{size}{$key}); + } + $self->{size}{$key} = $s[7]; + + foreach my $alg (@alg) { + my $digest = Digest->new($CHECKSUMS->{$alg}{name}); + open my $fh, '<', $file or syserr(g_('cannot open file %s'), $file); + $digest->addfile($fh); + close $fh; + + my $newsum = $digest->hexdigest; + if (not $opts{update} and exists $self->{checksums}{$key}{$alg} and + $self->{checksums}{$key}{$alg} ne $newsum) { + error(g_('file %s has checksum %s instead of expected %s (algorithm %s)'), + $file, $newsum, $self->{checksums}{$key}{$alg}, $alg); + } + $self->{checksums}{$key}{$alg} = $newsum; + } +} + +=item $ck->add_from_string($alg, $value, %opts) + +Add checksums of type $alg that are stored in the $value variable. +$value can be multi-lines, each line should be a space separated list +of checksum, file size and filename. Leading or trailing spaces are +not allowed. + +It the object already contains checksums information associated to the +filenames, it will error out if the newly read information does not match +what's stored, and the caller did not request that it be updated with +the boolean "update" option. + +=cut + +sub add_from_string { + my ($self, $alg, $fieldtext, %opts) = @_; + $alg = lc($alg); + my $rx_fname = qr/[0-9a-zA-Z][-+:.,=0-9a-zA-Z_~]+/; + my $regex = checksums_get_property($alg, 'regex'); + my $checksums = $self->{checksums}; + + for my $checksum (split /\n */, $fieldtext) { + next if $checksum eq ''; + unless ($checksum =~ m/^($regex)\s+(\d+)\s+($rx_fname)$/) { + error(g_('invalid line in %s checksums string: %s'), + $alg, $checksum); + } + ## no critic (RegularExpressions::ProhibitCaptureWithoutTest) + my ($sum, $size, $file) = ($1, $2, $3); + if (not $opts{update} and exists($checksums->{$file}{$alg}) + and $checksums->{$file}{$alg} ne $sum) { + error(g_("conflicting checksums '%s' and '%s' for file '%s'"), + $checksums->{$file}{$alg}, $sum, $file); + } + if (not $opts{update} and exists $self->{size}{$file} + and $self->{size}{$file} != $size) { + error(g_("conflicting file sizes '%u' and '%u' for file '%s'"), + $self->{size}{$file}, $size, $file); + } + push @{$self->{files}}, $file unless exists $self->{size}{$file}; + $checksums->{$file}{$alg} = $sum; + $self->{size}{$file} = $size; + } +} + +=item $ck->add_from_control($control, %opts) + +Read checksums from Checksums-* fields stored in the L<Dpkg::Control> object +$control. It uses $self->add_from_string() on the field values to do the +actual work. + +If the option "use_files_for_md5" evaluates to true, then the "Files" +field is used in place of the "Checksums-Md5" field. By default the option +is false. + +=cut + +sub add_from_control { + my ($self, $control, %opts) = @_; + $opts{use_files_for_md5} //= 0; + foreach my $alg (checksums_get_list()) { + my $key = "Checksums-$alg"; + $key = 'Files' if ($opts{use_files_for_md5} and $alg eq 'md5'); + if (exists $control->{$key}) { + $self->add_from_string($alg, $control->{$key}, %opts); + } + } +} + +=item @files = $ck->get_files() + +Return the list of files whose checksums are stored in the object. + +=cut + +sub get_files { + my $self = shift; + return @{$self->{files}}; +} + +=item $bool = $ck->has_file($file) + +Return true if we have checksums for the given file. Returns false +otherwise. + +=cut + +sub has_file { + my ($self, $file) = @_; + return exists $self->{size}{$file}; +} + +=item $ck->remove_file($file) + +Remove all checksums of the given file. + +=cut + +sub remove_file { + my ($self, $file) = @_; + return unless $self->has_file($file); + delete $self->{checksums}{$file}; + delete $self->{size}{$file}; + @{$self->{files}} = grep { $_ ne $file } $self->get_files(); +} + +=item $checksum = $ck->get_checksum($file, $alg) + +Return the checksum of type $alg for the requested $file. This will not +compute the checksum but only return the checksum stored in the object, if +any. + +If $alg is not defined, it returns a reference to a hash: keys are +the checksum algorithms and values are the checksums themselves. The +hash returned must not be modified, it's internal to the object. + +=cut + +sub get_checksum { + my ($self, $file, $alg) = @_; + $alg = lc($alg) if defined $alg; + if (exists $self->{checksums}{$file}) { + return $self->{checksums}{$file} unless defined $alg; + return $self->{checksums}{$file}{$alg}; + } + return; +} + +=item $size = $ck->get_size($file) + +Return the size of the requested file if it's available in the object. + +=cut + +sub get_size { + my ($self, $file) = @_; + return $self->{size}{$file}; +} + +=item $bool = $ck->has_strong_checksums($file) + +Return a boolean on whether the file has a strong checksum. + +=cut + +sub has_strong_checksums { + my ($self, $file) = @_; + + foreach my $alg (checksums_get_list()) { + return 1 if defined $self->get_checksum($file, $alg) and + checksums_get_property($alg, 'strong'); + } + + return 0; +} + +=item $ck->export_to_string($alg, %opts) + +Return a multi-line string containing the checksums of type $alg. The +string can be stored as-is in a Checksum-* field of a L<Dpkg::Control> +object. + +=cut + +sub export_to_string { + my ($self, $alg, %opts) = @_; + my $res = ''; + foreach my $file ($self->get_files()) { + my $sum = $self->get_checksum($file, $alg); + my $size = $self->get_size($file); + next unless defined $sum and defined $size; + $res .= "\n$sum $size $file"; + } + return $res; +} + +=item $ck->export_to_control($control, %opts) + +Export the checksums in the Checksums-* fields of the L<Dpkg::Control> +$control object. + +=cut + +sub export_to_control { + my ($self, $control, %opts) = @_; + $opts{use_files_for_md5} //= 0; + foreach my $alg (checksums_get_list()) { + my $key = "Checksums-$alg"; + $key = 'Files' if ($opts{use_files_for_md5} and $alg eq 'md5'); + $control->{$key} = $self->export_to_string($alg, %opts); + } +} + +=back + +=head1 CHANGES + +=head2 Version 1.04 (dpkg 1.20.0) + +Remove warning: For obsolete property 'program'. + +=head2 Version 1.03 (dpkg 1.18.5) + +New property: Add new 'strong' property. + +New member: $ck->has_strong_checksums(). + +=head2 Version 1.02 (dpkg 1.18.0) + +Obsolete property: Getting the 'program' checksum property will warn and +return undef, the Digest module is used internally now. + +New property: Add new 'name' property with the name of the Digest algorithm +to use. + +=head2 Version 1.01 (dpkg 1.17.6) + +New argument: Accept an options argument in $ck->export_to_string(). + +New option: Accept new option 'update' in $ck->add_from_file() and +$ck->add_from_control(). + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Compression.pm b/scripts/Dpkg/Compression.pm new file mode 100644 index 0000000..9e6074d --- /dev/null +++ b/scripts/Dpkg/Compression.pm @@ -0,0 +1,447 @@ +# Copyright © 2007-2022 Guillem Jover <guillem@debian.org> +# Copyright © 2010 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Compression - simple database of available compression methods + +=head1 DESCRIPTION + +This modules provides a few public functions and a public regex to +interact with the set of supported compression methods. + +=cut + +package Dpkg::Compression 2.01; + +use strict; +use warnings; + +our @EXPORT = qw( + compression_is_supported + compression_get_list + compression_get_property + compression_guess_from_filename + compression_get_file_extension_regex + compression_get_file_extension + compression_get_default + compression_set_default + compression_get_default_level + compression_set_default_level + compression_get_level + compression_set_level + compression_is_valid_level + compression_get_threads + compression_set_threads + compression_get_cmdline_compress + compression_get_cmdline_decompress +); + +use Exporter qw(import); +use Config; +use List::Util qw(any); + +use Dpkg::ErrorHandling; +use Dpkg::Gettext; + +my %COMP = ( + gzip => { + file_ext => 'gz', + comp_prog => [ 'gzip', '-n' ], + decomp_prog => [ 'gunzip' ], + default_level => 9, + }, + bzip2 => { + file_ext => 'bz2', + comp_prog => [ 'bzip2' ], + decomp_prog => [ 'bunzip2' ], + default_level => 9, + }, + lzma => { + file_ext => 'lzma', + comp_prog => [ 'xz', '--format=lzma' ], + decomp_prog => [ 'unxz', '--format=lzma' ], + default_level => 6, + }, + xz => { + file_ext => 'xz', + comp_prog => [ 'xz' ], + decomp_prog => [ 'unxz' ], + default_level => 6, + }, +); + +# The gzip --rsyncable option is not universally supported, so we need to +# conditionally use it. Ideally we would invoke 'gzip --help' and check +# whether the option is supported, but that would imply forking and executing +# that process for any module that ends up loading this one, which is not +# acceptable performance-wise. Instead we will approximate it by osname, which +# is not ideal, but better than nothing. +# +# Requires GNU gzip >= 1.7 for the --rsyncable option. On AIX GNU gzip is +# too old. On the BSDs they use their own implementation based on zlib, +# which does not currently support the --rsyncable option. +if (any { $Config{osname} eq $_ } qw(linux gnu solaris)) { + push @{$COMP{gzip}{comp_prog}}, '--rsyncable'; +} + +my $default_compression = 'xz'; +my $default_compression_level = undef; +my $default_compression_threads = 0; + +my $regex = join '|', map { $_->{file_ext} } values %COMP; +my $compression_re_file_ext = qr/(?:$regex)/; + +=head1 FUNCTIONS + +=over 4 + +=item @list = compression_get_list() + +Returns a list of supported compression methods (sorted alphabetically). + +=cut + +sub compression_get_list { + my @list = sort keys %COMP; + return @list; +} + +=item compression_is_supported($comp) + +Returns a boolean indicating whether the give compression method is +known and supported. + +=cut + +sub compression_is_supported { + my $comp = shift; + + return exists $COMP{$comp}; +} + +=item compression_get_property($comp, $property) + +Returns the requested property of the compression method. Returns undef if +either the property or the compression method doesn't exist. Valid +properties currently include "file_ext" for the file extension, +"default_level" for the default compression level, +"comp_prog" for the name of the compression program and "decomp_prog" for +the name of the decompression program. + +This function is deprecated, please switch to one of the new specialized +getters instead. + +=cut + +sub compression_get_property { + my ($comp, $property) = @_; + + #warnings::warnif('deprecated', + # 'Dpkg::Compression::compression_get_property() is deprecated, ' . + # 'use one of the specialized getters instead'); + return unless compression_is_supported($comp); + return $COMP{$comp}{$property} if exists $COMP{$comp}{$property}; + return; +} + +=item compression_guess_from_filename($filename) + +Returns the compression method that is likely used on the indicated +filename based on its file extension. + +=cut + +sub compression_guess_from_filename { + my $filename = shift; + foreach my $comp (compression_get_list()) { + my $ext = $COMP{$comp}{file_ext}; + if ($filename =~ /^(.*)\.\Q$ext\E$/) { + return $comp; + } + } + return; +} + +=item $regex = compression_get_file_extension_regex() + +Returns a regex that matches a file extension of a file compressed with +one of the supported compression methods. + +=cut + +sub compression_get_file_extension_regex { + return $compression_re_file_ext; +} + +=item $ext = compression_get_file_extension($comp) + +Return the file extension for the compressor $comp. + +=cut + +sub compression_get_file_extension { + my $comp = shift; + + error(g_('%s is not a supported compression'), $comp) + unless compression_is_supported($comp); + + return $COMP{$comp}{file_ext}; +} + +=item $comp = compression_get_default() + +Return the default compression method. It is "xz" unless +compression_set_default() has been used to change it. + +=cut + +sub compression_get_default { + return $default_compression; +} + +=item compression_set_default($comp) + +Change the default compression method. Errors out if the +given compression method is not supported. + +=cut + +sub compression_set_default { + my $method = shift; + error(g_('%s is not a supported compression'), $method) + unless compression_is_supported($method); + $default_compression = $method; +} + +=item $level = compression_get_default_level() + +Return the global default compression level used when compressing data if +it has been set, otherwise the default level for the default compressor. + +It's "9" for "gzip" and "bzip2", "6" for "xz" and "lzma", unless +compression_set_default_level() has been used to change it. + +=cut + +sub compression_get_default_level { + if (defined $default_compression_level) { + return $default_compression_level; + } else { + return $COMP{$default_compression}{default_level}; + } +} + +=item compression_set_default_level($level) + +Change the global default compression level. Passing undef as the level will +reset it to the global default compressor specific default, otherwise errors +out if the level is not valid (see compression_is_valid_level()). + +=cut + +sub compression_set_default_level { + my $level = shift; + error(g_('%s is not a compression level'), $level) + if defined($level) and not compression_is_valid_level($level); + $default_compression_level = $level; +} + +=item $level = compression_get_level($comp) + +Return the compression level used when compressing data with a specific +compressor. The value returned is the specific compression level if it has +been set, otherwise the global default compression level if it has been set, +falling back to the specific default compression level. + +=cut + +sub compression_get_level { + my $comp = shift; + + error(g_('%s is not a supported compression'), $comp) + unless compression_is_supported($comp); + + return $COMP{$comp}{level} // + $default_compression_level // + $COMP{$comp}{default_level}; +} + +=item compression_set_level($comp, $level) + +Change the compression level for a specific compressor. Passing undef as +the level will reset it to the specific default compressor level, otherwise +errors out if the level is not valid (see compression_is_valid_level()). + +=cut + +sub compression_set_level { + my ($comp, $level) = @_; + + error(g_('%s is not a supported compression'), $comp) + unless compression_is_supported($comp); + error(g_('%s is not a compression level'), $level) + if defined $level && ! compression_is_valid_level($level); + + $COMP{$comp}{level} = $level; +} + +=item compression_is_valid_level($level) + +Returns a boolean indicating whether $level is a valid compression level +(it must be either a number between 1 and 9 or "fast" or "best") + +=cut + +sub compression_is_valid_level { + my $level = shift; + return $level =~ /^([1-9]|fast|best)$/; +} + +=item $threads = compression_get_threads() + +Return the number of threads to use for compression and decompression. + +=cut + +sub compression_get_threads { + return $default_compression_threads; +} + +=item compression_set_threads($threads) + +Change the threads to use for compression and decompression. Passing C<undef> +or B<0> requests to use automatic mode, based on the current CPU cores on +the system. + +=cut + +sub compression_set_threads { + my $threads = shift; + + error(g_('compression threads %s is not a number'), $threads) + if defined $threads && $threads !~ m/^\d+$/; + $default_compression_threads = $threads; +} + +=item @exec = compression_get_cmdline_compress($comp) + +Returns a list ready to be passed to exec(), its first element is the +program name for compression and the following elements are parameters +for the program. + +When executed the program will act as a filter between its standard input +and its standard output. + +=cut + +sub compression_get_cmdline_compress { + my $comp = shift; + + error(g_('%s is not a supported compression'), $comp) + unless compression_is_supported($comp); + + my @prog = @{$COMP{$comp}{comp_prog}}; + my $level = compression_get_level($comp); + if ($level =~ m/^[1-9]$/) { + push @prog, "-$level"; + } else { + push @prog, "--$level"; + } + my $threads = compression_get_threads(); + if ($comp eq 'xz') { + # Do not generate warnings when adjusting memory usage, nor + # exit with non-zero due to those not emitted warnings. + push @prog, qw(--quiet --no-warn); + + # Do not let xz fallback to single-threaded mode, to avoid + # non-reproducible output. + push @prog, '--no-adjust'; + + # The xz -T1 option selects a single-threaded mode which generates + # different output than in multi-threaded mode. To avoid the + # non-reproducible output we pass -T+1 (supported with xz >= 5.4.0) + # to request multi-threaded mode with a single thread. + push @prog, $threads == 1 ? '-T+1' : "-T$threads"; + } + return @prog; +} + +=item @exec = compression_get_cmdline_decompress($comp) + +Returns a list ready to be passed to exec(), its first element is the +program name for decompression and the following elements are parameters +for the program. + +When executed the program will act as a filter between its standard input +and its standard output. + +=cut + +sub compression_get_cmdline_decompress { + my $comp = shift; + + error(g_('%s is not a supported compression'), $comp) + unless compression_is_supported($comp); + + my @prog = @{$COMP{$comp}{decomp_prog}}; + + my $threads = compression_get_threads(); + if ($comp eq 'xz') { + push @prog, "-T$threads"; + } + + return @prog; +} + +=back + +=head1 CHANGES + +=head2 Version 2.01 (dpkg 1.21.14) + +New functions: compression_get_file_extension(), compression_get_level(), +compression_set_level(), compression_get_cmdline_compress(), +compression_get_cmdline_decompress(), compression_get_threads() and +compression_set_threads(). + +Deprecated functions: compression_get_property(). + +=head2 Version 2.00 (dpkg 1.20.0) + +Hide variables: $default_compression, $default_compression_level +and $compression_re_file_ext. + +=head2 Version 1.02 (dpkg 1.17.2) + +New function: compression_get_file_extension_regex() + +Deprecated variables: $default_compression, $default_compression_level +and $compression_re_file_ext + +=head2 Version 1.01 (dpkg 1.16.1) + +Default compression level is not global any more, it is per compressor type. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Compression/FileHandle.pm b/scripts/Dpkg/Compression/FileHandle.pm new file mode 100644 index 0000000..c25220a --- /dev/null +++ b/scripts/Dpkg/Compression/FileHandle.pm @@ -0,0 +1,479 @@ +# Copyright © 2008-2010 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2012-2014 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Compression::FileHandle - class dealing transparently with file compression + +=head1 SYNOPSIS + + use Dpkg::Compression::FileHandle; + + my ($fh, @lines); + + $fh = Dpkg::Compression::FileHandle->new(filename => 'sample.gz'); + print $fh "Something\n"; + close $fh; + + $fh = Dpkg::Compression::FileHandle->new(); + open($fh, '>', 'sample.bz2'); + print $fh "Something\n"; + close $fh; + + $fh = Dpkg::Compression::FileHandle->new(); + $fh->open('sample.xz', 'w'); + $fh->print("Something\n"); + $fh->close(); + + $fh = Dpkg::Compression::FileHandle->new(filename => 'sample.gz'); + @lines = <$fh>; + close $fh; + + $fh = Dpkg::Compression::FileHandle->new(); + open($fh, '<', 'sample.bz2'); + @lines = <$fh>; + close $fh; + + $fh = Dpkg::Compression::FileHandle->new(); + $fh->open('sample.xz', 'r'); + @lines = $fh->getlines(); + $fh->close(); + +=head1 DESCRIPTION + +Dpkg::Compression::FileHandle is a class that can be used +like any filehandle and that deals transparently with compressed +files. By default, the compression scheme is guessed from the filename +but you can override this behavior with the method set_compression(). + +If you don't open the file explicitly, it will be auto-opened on the +first read or write operation based on the filename set at creation time +(or later with the set_filename() method). + +Once a file has been opened, the filehandle must be closed before being +able to open another file. + +=cut + +package Dpkg::Compression::FileHandle 1.01; + +use strict; +use warnings; + +use Carp; + +use Dpkg::Compression; +use Dpkg::Compression::Process; +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +use parent qw(IO::File Tie::Handle); + +# Useful reference to understand some kludges required to +# have the class behave like a filehandle +# http://blog.woobling.org/2009/10/are-filehandles-objects.html + +=head1 STANDARD FUNCTIONS + +The standard functions acting on filehandles should accept a +Dpkg::Compression::FileHandle object transparently including +open() (only when using the variant with 3 parameters), close(), +binmode(), eof(), fileno(), getc(), print(), printf(), read(), +sysread(), say(), write(), syswrite(), seek(), sysseek(), tell(). + +Note however that seek() and sysseek() will only work on uncompressed +files as compressed files are really pipes to the compressor programs +and you can't seek on a pipe. + +=head1 FileHandle METHODS + +The class inherits from L<IO::File> so all methods that work on this +class should work for Dpkg::Compression::FileHandle too. There +may be exceptions though. + +=head1 PUBLIC METHODS + +=over 4 + +=item $fh = Dpkg::Compression::FileHandle->new(%opts) + +Creates a new filehandle supporting on-the-fly compression/decompression. +Supported options are "filename", "compression", "compression_level" (see +respective set_* functions) and "add_comp_ext". If "add_comp_ext" +evaluates to true, then the extension corresponding to the selected +compression scheme is automatically added to the recorded filename. It's +obviously incompatible with automatic detection of the compression method. + +=cut + +# Class methods +sub new { + my ($this, %args) = @_; + my $class = ref($this) || $this; + my $self = IO::File->new(); + # Tying is required to overload the open functions and to auto-open + # the file on first read/write operation + tie *$self, $class, $self; ## no critic (Miscellanea::ProhibitTies) + bless $self, $class; + # Initializations + *$self->{compression} = 'auto'; + *$self->{compressor} = Dpkg::Compression::Process->new(); + *$self->{add_comp_ext} = $args{add_compression_extension} || + $args{add_comp_ext} || 0; + *$self->{allow_sigpipe} = 0; + if (exists $args{filename}) { + $self->set_filename($args{filename}); + } + if (exists $args{compression}) { + $self->set_compression($args{compression}); + } + if (exists $args{compression_level}) { + $self->set_compression_level($args{compression_level}); + } + return $self; +} + +=item $fh->ensure_open($mode, %opts) + +Ensure the file is opened in the requested mode ("r" for read and "w" for +write). The options are passed down to the compressor's spawn() call, if one +is used. Opens the file with the recorded filename if needed. If the file +is already open but not in the requested mode, then it errors out. + +=cut + +sub ensure_open { + my ($self, $mode, %opts) = @_; + if (exists *$self->{mode}) { + return if *$self->{mode} eq $mode; + croak "ensure_open requested incompatible mode: $mode"; + } else { + # Sanitize options. + delete $opts{from_pipe}; + delete $opts{from_file}; + delete $opts{to_pipe}; + delete $opts{to_file}; + + if ($mode eq 'w') { + $self->_open_for_write(%opts); + } elsif ($mode eq 'r') { + $self->_open_for_read(%opts); + } else { + croak "invalid mode in ensure_open: $mode"; + } + } +} + +## +## METHODS FOR TIED HANDLE +## +sub TIEHANDLE { + my ($class, $self) = @_; + return $self; +} + +sub WRITE { + my ($self, $scalar, $length, $offset) = @_; + $self->ensure_open('w'); + return *$self->{file}->write($scalar, $length, $offset); +} + +sub READ { + my ($self, $scalar, $length, $offset) = @_; + $self->ensure_open('r'); + return *$self->{file}->read($scalar, $length, $offset); +} + +sub READLINE { + my ($self) = shift; + $self->ensure_open('r'); + return *$self->{file}->getlines() if wantarray; + return *$self->{file}->getline(); +} + +sub OPEN { + my ($self, @args) = @_; + + if (scalar @args == 2) { + my ($mode, $filename) = @args; + $self->set_filename($filename); + if ($mode eq '>') { + $self->_open_for_write(); + } elsif ($mode eq '<') { + $self->_open_for_read(); + } else { + croak 'Dpkg::Compression::FileHandle does not support ' . + "open() mode $mode"; + } + } else { + croak 'Dpkg::Compression::FileHandle only supports open() ' . + 'with 3 parameters'; + } + return 1; # Always works (otherwise errors out) +} + +sub CLOSE { + my ($self, @args) = @_; + my $ret = 1; + if (defined *$self->{file}) { + $ret = *$self->{file}->close(@args) if *$self->{file}->opened(); + } else { + $ret = 0; + } + $self->_cleanup(); + return $ret; +} + +sub FILENO { + my ($self, @args) = @_; + + return *$self->{file}->fileno(@args) if defined *$self->{file}; + return; +} + +sub EOF { + # Since perl 5.12, an integer parameter is passed describing how the + # function got called, just ignore it. + my ($self, $param, @args) = @_; + + return *$self->{file}->eof(@args) if defined *$self->{file}; + return 1; +} + +sub SEEK { + my ($self, @args) = @_; + + return *$self->{file}->seek(@args) if defined *$self->{file}; + return 0; +} + +sub TELL { + my ($self, @args) = @_; + + return *$self->{file}->tell(@args) if defined *$self->{file}; + return -1; +} + +sub BINMODE { + my ($self, @args) = @_; + + return *$self->{file}->binmode(@args) if defined *$self->{file}; + return; +} + +## +## NORMAL METHODS +## + +=item $fh->set_compression($comp) + +Defines the compression method used. $comp should one of the methods supported by +L<Dpkg::Compression> or "none" or "auto". "none" indicates that the file is +uncompressed and "auto" indicates that the method must be guessed based +on the filename extension used. + +=cut + +sub set_compression { + my ($self, $method) = @_; + if ($method ne 'none' and $method ne 'auto') { + *$self->{compressor}->set_compression($method); + } + *$self->{compression} = $method; +} + +=item $fh->set_compression_level($level) + +Indicate the desired compression level. It should be a value accepted +by the function compression_is_valid_level() of L<Dpkg::Compression>. + +=cut + +sub set_compression_level { + my ($self, $level) = @_; + *$self->{compressor}->set_compression_level($level); +} + +=item $fh->set_filename($name, [$add_comp_ext]) + +Use $name as filename when the file must be opened/created. If +$add_comp_ext is passed, it indicates whether the default extension +of the compression method must be automatically added to the filename +(or not). + +=cut + +sub set_filename { + my ($self, $filename, $add_comp_ext) = @_; + *$self->{filename} = $filename; + # Automatically add compression extension to filename + if (defined($add_comp_ext)) { + *$self->{add_comp_ext} = $add_comp_ext; + } + my $comp_ext_regex = compression_get_file_extension_regex(); + if (*$self->{add_comp_ext} and $filename =~ /\.$comp_ext_regex$/) { + warning('filename %s already has an extension of a compressed file ' . + 'and add_comp_ext is active', $filename); + } +} + +=item $file = $fh->get_filename() + +Returns the filename that would be used when the filehandle must +be opened (both in read and write mode). This function errors out +if "add_comp_ext" is enabled while the compression method is set +to "auto". The returned filename includes the extension of the compression +method if "add_comp_ext" is enabled. + +=cut + +sub get_filename { + my $self = shift; + my $comp = *$self->{compression}; + if (*$self->{add_comp_ext}) { + if ($comp eq 'auto') { + croak 'automatic detection of compression is ' . + 'incompatible with add_comp_ext'; + } elsif ($comp eq 'none') { + return *$self->{filename}; + } else { + return *$self->{filename} . '.' . + compression_get_file_extension($comp); + } + } else { + return *$self->{filename}; + } +} + +=item $ret = $fh->use_compression() + +Returns "0" if no compression is used and the compression method used +otherwise. If the compression is set to "auto", the value returned +depends on the extension of the filename obtained with the get_filename() +method. + +=cut + +sub use_compression { + my $self = shift; + my $comp = *$self->{compression}; + if ($comp eq 'none') { + return 0; + } elsif ($comp eq 'auto') { + $comp = compression_guess_from_filename($self->get_filename()); + *$self->{compressor}->set_compression($comp) if $comp; + } + return $comp; +} + +=item $real_fh = $fh->get_filehandle() + +Returns the real underlying filehandle. Useful if you want to pass it +along in a derived class. + +=cut + +sub get_filehandle { + my $self = shift; + return *$self->{file} if exists *$self->{file}; +} + +## INTERNAL METHODS + +sub _open_for_write { + my ($self, %opts) = @_; + my $filehandle; + + croak 'cannot reopen an already opened compressed file' + if exists *$self->{mode}; + + if ($self->use_compression()) { + *$self->{compressor}->compress(from_pipe => \$filehandle, + to_file => $self->get_filename(), %opts); + } else { + CORE::open($filehandle, '>', $self->get_filename) + or syserr(g_('cannot write %s'), $self->get_filename()); + } + *$self->{mode} = 'w'; + *$self->{file} = $filehandle; +} + +sub _open_for_read { + my ($self, %opts) = @_; + my $filehandle; + + croak 'cannot reopen an already opened compressed file' + if exists *$self->{mode}; + + if ($self->use_compression()) { + *$self->{compressor}->uncompress(to_pipe => \$filehandle, + from_file => $self->get_filename(), %opts); + *$self->{allow_sigpipe} = 1; + } else { + CORE::open($filehandle, '<', $self->get_filename) + or syserr(g_('cannot read %s'), $self->get_filename()); + } + *$self->{mode} = 'r'; + *$self->{file} = $filehandle; +} + +sub _cleanup { + my $self = shift; + my $cmdline = *$self->{compressor}{cmdline} // ''; + *$self->{compressor}->wait_end_process(nocheck => *$self->{allow_sigpipe}); + if (*$self->{allow_sigpipe}) { + require POSIX; + unless (($? == 0) || (POSIX::WIFSIGNALED($?) && + (POSIX::WTERMSIG($?) == POSIX::SIGPIPE()))) { + subprocerr($cmdline); + } + *$self->{allow_sigpipe} = 0; + } + delete *$self->{mode}; + delete *$self->{file}; +} + +=back + +=head1 DERIVED CLASSES + +If you want to create a class that inherits from +Dpkg::Compression::FileHandle you must be aware that +the object is a reference to a GLOB that is returned by Symbol::gensym() +and as such it's not a HASH. + +You can store internal data in a hash but you have to use +C<*$self->{...}> to access the associated hash like in the example below: + + sub set_option { + my ($self, $value) = @_; + *$self->{option} = $value; + } + +=head1 CHANGES + +=head2 Version 1.01 (dpkg 1.17.11) + +New argument: $fh->ensure_open() accepts an %opts argument. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut +1; diff --git a/scripts/Dpkg/Compression/Process.pm b/scripts/Dpkg/Compression/Process.pm new file mode 100644 index 0000000..cf4c504 --- /dev/null +++ b/scripts/Dpkg/Compression/Process.pm @@ -0,0 +1,208 @@ +# Copyright © 2008-2010 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Compression::Process - run compression/decompression processes + +=head1 DESCRIPTION + +This module provides an object oriented interface to run and manage +compression/decompression processes. + +=cut + +package Dpkg::Compression::Process 1.00; + +use strict; +use warnings; + +use Carp; + +use Dpkg::Compression; +use Dpkg::ErrorHandling; +use Dpkg::Gettext; +use Dpkg::IPC; + +=head1 METHODS + +=over 4 + +=item $proc = Dpkg::Compression::Process->new(%opts) + +Create a new instance of the object. Supported options are "compression" +and "compression_level" (see corresponding set_* functions). + +=cut + +sub new { + my ($this, %args) = @_; + my $class = ref($this) || $this; + my $self = {}; + bless $self, $class; + $self->set_compression($args{compression} || compression_get_default()); + $self->set_compression_level($args{compression_level} || + compression_get_default_level()); + return $self; +} + +=item $proc->set_compression($comp) + +Select the compression method to use. It errors out if the method is not +supported according to compression_is_supported() (of +L<Dpkg::Compression>). + +=cut + +sub set_compression { + my ($self, $method) = @_; + error(g_('%s is not a supported compression method'), $method) + unless compression_is_supported($method); + $self->{compression} = $method; +} + +=item $proc->set_compression_level($level) + +Select the compression level to use. It errors out if the level is not +valid according to compression_is_valid_level() (of +L<Dpkg::Compression>). + +=cut + +sub set_compression_level { + my ($self, $level) = @_; + + compression_set_level($self->{compression}, $level); +} + +=item @exec = $proc->get_compress_cmdline() + +=item @exec = $proc->get_uncompress_cmdline() + +Returns a list ready to be passed to exec(), its first element is the +program name (either for compression or decompression) and the following +elements are parameters for the program. + +When executed the program acts as a filter between its standard input +and its standard output. + +=cut + +sub get_compress_cmdline { + my $self = shift; + + return compression_get_cmdline_compress($self->{compression}); +} + +sub get_uncompress_cmdline { + my $self = shift; + + return compression_get_cmdline_decompress($self->{compression}); +} + +sub _check_opts { + my ($self, %opts) = @_; + # Check for proper cleaning before new start + error(g_('Dpkg::Compression::Process can only start one subprocess at a time')) + if $self->{pid}; + # Check options + my $to = my $from = 0; + foreach my $thing (qw(file handle string pipe)) { + $to++ if $opts{"to_$thing"}; + $from++ if $opts{"from_$thing"}; + } + croak 'exactly one to_* parameter is needed' if $to != 1; + croak 'exactly one from_* parameter is needed' if $from != 1; + return %opts; +} + +=item $proc->compress(%opts) + +Starts a compressor program. You must indicate where it will read its +uncompressed data from and where it will write its compressed data to. +This is accomplished by passing one parameter C<to_*> and one parameter +C<from_*> as accepted by Dpkg::IPC::spawn(). + +You must call wait_end_process() after having called this method to +properly close the sub-process (and verify that it exited without error). + +=cut + +sub compress { + my ($self, %opts) = @_; + + $self->_check_opts(%opts); + my @prog = $self->get_compress_cmdline(); + $opts{exec} = \@prog; + $self->{cmdline} = "@prog"; + $self->{pid} = spawn(%opts); + delete $self->{pid} if $opts{to_string}; # wait_child already done +} + +=item $proc->uncompress(%opts) + +Starts a decompressor program. You must indicate where it will read its +compressed data from and where it will write its uncompressed data to. +This is accomplished by passing one parameter C<to_*> and one parameter +C<from_*> as accepted by Dpkg::IPC::spawn(). + +You must call wait_end_process() after having called this method to +properly close the sub-process (and verify that it exited without error). + +=cut + +sub uncompress { + my ($self, %opts) = @_; + + $self->_check_opts(%opts); + my @prog = $self->get_uncompress_cmdline(); + $opts{exec} = \@prog; + $self->{cmdline} = "@prog"; + $self->{pid} = spawn(%opts); + delete $self->{pid} if $opts{to_string}; # wait_child already done +} + +=item $proc->wait_end_process(%opts) + +Call Dpkg::IPC::wait_child() to wait until the sub-process has exited +and verify its return code. Any given option will be forwarded to +the wait_child() function. Most notably you can use the "nocheck" option +to verify the return code yourself instead of letting wait_child() do +it for you. + +=cut + +sub wait_end_process { + my ($self, %opts) = @_; + $opts{cmdline} //= $self->{cmdline}; + wait_child($self->{pid}, %opts) if $self->{pid}; + delete $self->{pid}; + delete $self->{cmdline}; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Conf.pm b/scripts/Dpkg/Conf.pm new file mode 100644 index 0000000..2894d35 --- /dev/null +++ b/scripts/Dpkg/Conf.pm @@ -0,0 +1,269 @@ +# Copyright © 2009-2010 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Conf - parse dpkg configuration files + +=head1 DESCRIPTION + +The Dpkg::Conf object can be used to read options from a configuration +file. It can export an array that can then be parsed exactly like @ARGV. + +=cut + +package Dpkg::Conf 1.04; + +use strict; +use warnings; + +use Carp; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +use parent qw(Dpkg::Interface::Storable); + +use overload + '@{}' => sub { return [ $_[0]->get_options() ] }, + fallback => 1; + +=head1 METHODS + +=over 4 + +=item $conf = Dpkg::Conf->new(%opts) + +Create a new Dpkg::Conf object. Some options can be set through %opts: +if allow_short evaluates to true (it defaults to false), then short +options are allowed in the configuration file, they should be prepended +with a single hyphen. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = { + options => [], + allow_short => 0, + }; + foreach my $opt (keys %opts) { + $self->{$opt} = $opts{$opt}; + } + bless $self, $class; + + return $self; +} + +=item @$conf + +=item @options = $conf->get_options() + +Returns the list of options that can be parsed like @ARGV. + +=cut + +sub get_options { + my $self = shift; + + return @{$self->{options}}; +} + +=item $conf->load($file) + +Read options from a file. Return the number of options parsed. + +=item $conf->load_system_config($file) + +Read options from a system configuration file. + +Return the number of options parsed. + +=cut + +sub load_system_config { + my ($self, $file) = @_; + + return 0 unless -e "$Dpkg::CONFDIR/$file"; + return $self->load("$Dpkg::CONFDIR/$file"); +} + +=item $conf->load_user_config($file) + +Read options from a user configuration file. It will try to use the XDG +directory, either $XDG_CONFIG_HOME/dpkg/ or $HOME/.config/dpkg/. + +Return the number of options parsed. + +=cut + +sub load_user_config { + my ($self, $file) = @_; + + my $confdir = $ENV{XDG_CONFIG_HOME}; + $confdir ||= $ENV{HOME} . '/.config' if length $ENV{HOME}; + + return 0 unless length $confdir; + return 0 unless -e "$confdir/dpkg/$file"; + return $self->load("$confdir/dpkg/$file") if length $confdir; + return 0; +} + +=item $conf->load_config($file) + +Read options from system and user configuration files. + +Return the number of options parsed. + +=cut + +sub load_config { + my ($self, $file) = @_; + + my $nopts = 0; + + $nopts += $self->load_system_config($file); + $nopts += $self->load_user_config($file); + + return $nopts; +} + +=item $conf->parse($fh) + +Parse options from a file handle. When called multiple times, the parsed +options are accumulated. + +Return the number of options parsed. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + my $count = 0; + local $_; + + while (<$fh>) { + chomp; + s/^\s+//; # Strip leading spaces + s/\s+$//; # Strip trailing spaces + s/\s+=\s+/=/; # Remove spaces around the first = + s/\s+/=/ unless m/=/; # First spaces becomes = if no = + # Skip empty lines and comments + next if /^#/ or length == 0; + if (/^-[^-]/ and not $self->{allow_short}) { + warning(g_('short option not allowed in %s, line %d'), $desc, $.); + next; + } + if (/^([^=]+)(?:=(.*))?$/) { + my ($name, $value) = ($1, $2); + $name = "--$name" unless $name =~ /^-/; + if (defined $value) { + $value =~ s/^"(.*)"$/$1/ or $value =~ s/^'(.*)'$/$1/; + push @{$self->{options}}, "$name=$value"; + } else { + push @{$self->{options}}, $name; + } + $count++; + } else { + warning(g_('invalid syntax for option in %s, line %d'), $desc, $.); + } + } + return $count; +} + +=item $conf->filter(%opts) + +Filter the list of options, either removing or keeping all those that +return true when $opts{remove}->($option) or $opts{keep}->($option) is called. + +=cut + +sub filter { + my ($self, %opts) = @_; + my $remove = $opts{remove} // sub { 0 }; + my $keep = $opts{keep} // sub { 1 }; + + @{$self->{options}} = grep { not $remove->($_) and $keep->($_) } + @{$self->{options}}; +} + +=item $string = $conf->output([$fh]) + +Write the options in the given filehandle (if defined) and return a string +representation of the content (that would be) written. + +=item "$conf" + +Return a string representation of the content. + +=cut + +sub output { + my ($self, $fh) = @_; + my $ret = ''; + foreach my $opt ($self->get_options()) { + $opt =~ s/^--//; + $opt =~ s/^([^=]+)=(.*)$/$1 = "$2"/; + $opt .= "\n"; + print { $fh } $opt if defined $fh; + $ret .= $opt; + } + return $ret; +} + +=item $conf->save($file) + +Save the options in a file. + +=back + +=head1 CHANGES + +=head2 Version 1.04 (dpkg 1.20.0) + +Remove croak: For 'format_argv' in $conf->filter(). + +Remove methods: $conf->get(), $conf->set(). + +=head2 Version 1.03 (dpkg 1.18.8) + +Obsolete option: 'format_argv' in $conf->filter(). + +Obsolete methods: $conf->get(), $conf->set(). + +New methods: $conf->load_system_config(), $conf->load_system_user(), +$conf->load_config(). + +=head2 Version 1.02 (dpkg 1.18.5) + +New option: Accept new option 'format_argv' in $conf->filter(). + +New methods: $conf->get(), $conf->set(). + +=head2 Version 1.01 (dpkg 1.15.8) + +New method: $conf->filter() + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control.pm b/scripts/Dpkg/Control.pm new file mode 100644 index 0000000..29dd577 --- /dev/null +++ b/scripts/Dpkg/Control.pm @@ -0,0 +1,306 @@ +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Control - parse and manipulate official control-like information + +=head1 DESCRIPTION + +The Dpkg::Control object is a smart version of L<Dpkg::Control::Hash>. +It associates a type to the control information. That type can be +used to know what fields are allowed and in what order they must be +output. + +The types are constants that are exported by default. Here's the full +list: + +=over 4 + +=item CTRL_UNKNOWN + +This type is the default type, it indicates that the type of control +information is not yet known. + +=item CTRL_TMPL_SRC + +Corresponds to the first source package stanza in a F<debian/control> file in +a Debian source package. + +=item CTRL_TMPL_PKG + +Corresponds to subsequent binary package stanza in a F<debian/control> file +in a Debian source package. + +=item CTRL_REPO_RELEASE + +Corresponds to a F<Release> file in a repository. + +=item CTRL_REPO_SRC + +Corresponds to a stanza in a F<Sources> file of a source package +repository. + +=item CTRL_REPO_PKG + +Corresponds to a stanza in a F<Packages> file of a binary package +repository. + +=item CTRL_DSC + +Corresponds to a .dsc file of a Debian source package. + +=item CTRL_DEB + +Corresponds to the F<control> file generated by dpkg-gencontrol +(F<DEBIAN/control>) and to the same file inside .deb packages. + +=item CTRL_FILE_BUILDINFO + +Corresponds to a .buildinfo file. + +=item CTRL_FILE_CHANGES + +Corresponds to a .changes file. + +=item CTRL_FILE_VENDOR + +Corresponds to a vendor file in $Dpkg::CONFDIR/origins/. + +=item CTRL_FILE_STATUS + +Corresponds to a stanza in dpkg's F<status> file ($Dpkg::ADMINDIR/status). + +=item CTRL_CHANGELOG + +Corresponds to the output of dpkg-parsechangelog. + +=item CTRL_COPYRIGHT_HEADER + +Corresponds to the header stanza in a F<debian/copyright> file in +machine readable format. + +=item CTRL_COPYRIGHT_FILES + +Corresponds to a files stanza in a F<debian/copyright> file in +machine readable format. + +=item CTRL_COPYRIGHT_LICENSE + +Corresponds to a license stanza in a F<debian/copyright> file in +machine readable format. + +=item CTRL_TESTS + +Corresponds to a source package tests control file in F<debian/tests/control>. + +=item CTRL_INFO_SRC + +Alias for B<CTRL_TMPL_SRC>. + +=item CTRL_INFO_PKG + +Alias for B<CTRL_TMPL_PKG>. + +=item CTRL_PKG_SRC + +Alias for B<CTRL_DSC>. + +=item CTRL_PKG_DEB + +Alias for B<CTRL_DEB>. + +=item CTRL_INDEX_SRC + +Alias for B<CTRL_REPO_SRC>. + +=item CTRL_INDEX_PKG + +Alias for B<CTRL_REPO_PKG>. + +=back + +=cut + +package Dpkg::Control 1.04; + +use strict; +use warnings; + +our @EXPORT = qw( + CTRL_UNKNOWN + CTRL_TMPL_SRC + CTRL_TMPL_PKG + CTRL_REPO_RELEASE + CTRL_REPO_SRC + CTRL_REPO_PKG + CTRL_DSC + CTRL_DEB + CTRL_FILE_BUILDINFO + CTRL_FILE_CHANGES + CTRL_FILE_VENDOR + CTRL_FILE_STATUS + CTRL_CHANGELOG + CTRL_COPYRIGHT_HEADER + CTRL_COPYRIGHT_FILES + CTRL_COPYRIGHT_LICENSE + CTRL_TESTS + + CTRL_INFO_SRC + CTRL_INFO_PKG + CTRL_PKG_SRC + CTRL_PKG_DEB + CTRL_INDEX_SRC + CTRL_INDEX_PKG +); + +use Exporter qw(import); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control::Types; +use Dpkg::Control::Hash; +use Dpkg::Control::Fields; + +use parent qw(Dpkg::Control::Hash); + +=head1 METHODS + +All the methods of L<Dpkg::Control::Hash> are available. Those listed below +are either new or overridden with a different behavior. + +=over 4 + +=item $c = Dpkg::Control->new(%opts) + +If the "type" option is given, it's used to setup default values +for other options. See set_options() for more details. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = Dpkg::Control::Hash->new(); + bless $self, $class; + $self->set_options(%opts); + + return $self; +} + +=item $c->set_options(%opts) + +Changes the value of one or more options. If the "type" option is changed, +it is used first to define default values for others options. The option +"allow_pgp" is set to 1 for CTRL_DSC, CTRL_FILE_CHANGES and +CTRL_REPO_RELEASE and to 0 otherwise. The option "drop_empty" is set to 0 +for CTRL_TMPL_SRC and CTRL_TMPL_PKG and to 1 otherwise. The option "name" +is set to a textual description of the type of control information. + +The output order is also set to match the ordered list returned by +Dpkg::Control::Fields::field_ordered_list($type). + +=cut + +sub set_options { + my ($self, %opts) = @_; + if (exists $opts{type}) { + my $t = $opts{type}; + $$self->{allow_pgp} = ($t & (CTRL_DSC | CTRL_FILE_CHANGES | CTRL_REPO_RELEASE)) ? 1 : 0; + $$self->{drop_empty} = ($t & (CTRL_TMPL_SRC | CTRL_TMPL_PKG)) ? 0 : 1; + if ($t == CTRL_TMPL_SRC) { + $$self->{name} = g_('source package stanza of template control file'); + } elsif ($t == CTRL_TMPL_PKG) { + $$self->{name} = g_('binary package stanza of template control file'); + } elsif ($t == CTRL_CHANGELOG) { + $$self->{name} = g_('parsed version of changelog'); + } elsif ($t == CTRL_COPYRIGHT_HEADER) { + $$self->{name} = g_('header stanza of copyright file'); + } elsif ($t == CTRL_COPYRIGHT_FILES) { + $$self->{name} = g_('files stanza of copyright file'); + } elsif ($t == CTRL_COPYRIGHT_HEADER) { + $$self->{name} = g_('license stanza of copyright file'); + } elsif ($t == CTRL_TESTS) { + $$self->{name} = g_('source package tests control file'); + } elsif ($t == CTRL_REPO_RELEASE) { + $$self->{name} = sprintf(g_("repository's %s file"), 'Release'); + } elsif ($t == CTRL_REPO_SRC) { + $$self->{name} = sprintf(g_("stanza in repository's %s file"), 'Sources'); + } elsif ($t == CTRL_REPO_PKG) { + $$self->{name} = sprintf(g_("stanza in repository's %s file"), 'Packages'); + } elsif ($t == CTRL_DSC) { + $$self->{name} = g_('source package control file'); + } elsif ($t == CTRL_DEB) { + $$self->{name} = g_('binary package control file'); + } elsif ($t == CTRL_FILE_BUILDINFO) { + $$self->{name} = g_('build information file'); + } elsif ($t == CTRL_FILE_CHANGES) { + $$self->{name} = g_('upload changes control file'); + } elsif ($t == CTRL_FILE_VENDOR) { + $$self->{name} = g_('vendor file'); + } elsif ($t == CTRL_FILE_STATUS) { + $$self->{name} = g_("stanza in dpkg's status file"); + } + $self->set_output_order(field_ordered_list($opts{type})); + } + + # Options set by the user override default values + $$self->{$_} = $opts{$_} foreach keys %opts; +} + +=item $c->get_type() + +Returns the type of control information stored. See the type parameter +set during new(). + +=cut + +sub get_type { + my $self = shift; + return $$self->{type}; +} + +=back + +=head1 CHANGES + +=head2 Version 1.04 (dpkg 1.22.2) + +New types: CTRL_TMPL_SRC, CTRL_TMPL_PKG, CTRL_REPO_SRC, CTRL_REPO_PKG, +CTRL_DSC, CTRL_DEB. + +=head2 Version 1.03 (dpkg 1.18.11) + +New type: CTRL_FILE_BUILDINFO. + +=head2 Version 1.02 (dpkg 1.18.8) + +New type: CTRL_TESTS. + +=head2 Version 1.01 (dpkg 1.18.5) + +New types: CTRL_REPO_RELEASE, CTRL_COPYRIGHT_HEADER, CTRL_COPYRIGHT_FILES, +CTRL_COPYRIGHT_LICENSE. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Changelog.pm b/scripts/Dpkg/Control/Changelog.pm new file mode 100644 index 0000000..0d382ae --- /dev/null +++ b/scripts/Dpkg/Control/Changelog.pm @@ -0,0 +1,65 @@ +# Copyright © 2009 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Changelog - represent info fields output by dpkg-parsechangelog + +=head1 DESCRIPTION + +This class derives directly from L<Dpkg::Control> with the type +CTRL_CHANGELOG. + +=cut + +package Dpkg::Control::Changelog 1.00; + +use strict; +use warnings; + +use Dpkg::Control; + +use parent qw(Dpkg::Control); + +=head1 METHODS + +=over 4 + +=item $c = Dpkg::Control::Changelog->new() + +Create a new empty set of changelog related fields. + +=cut + +sub new { + my ($this, @args) = @_; + my $class = ref($this) || $this; + my $self = Dpkg::Control->new(type => CTRL_CHANGELOG, @args); + return bless $self, $class; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Fields.pm b/scripts/Dpkg/Control/Fields.pm new file mode 100644 index 0000000..a70f30c --- /dev/null +++ b/scripts/Dpkg/Control/Fields.pm @@ -0,0 +1,70 @@ +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Fields - manage (list of official) control fields + +=head1 DESCRIPTION + +The module contains a list of vendor-neutral and vendor-specific field names +with associated meta-data explaining in which type of control information +they are allowed. The vendor-neutral field names and all functions are +inherited from L<Dpkg::Control::FieldsCore>. + +=cut + +package Dpkg::Control::Fields 1.00; + +use strict; +use warnings; + +our @EXPORT = @Dpkg::Control::FieldsCore::EXPORT; + +use Carp; +use Exporter qw(import); + +use Dpkg::Control::FieldsCore; +use Dpkg::Vendor qw(run_vendor_hook); + +# Register vendor specifics fields +foreach my $op (run_vendor_hook('register-custom-fields')) { + next if not (defined $op and ref $op); # Skip when not implemented by vendor + my $func = shift @$op; + if ($func eq 'register') { + my ($field, $allowed_type, @opts) = @{$op}; + field_register($field, $allowed_type, @opts); + } elsif ($func eq 'insert_before') { + my ($type, $ref, @fields) = @{$op}; + field_insert_before($type, $ref, @fields); + } elsif ($func eq 'insert_after') { + my ($type, $ref, @fields) = @{$op}; + field_insert_after($type, $ref, @fields); + } else { + croak "vendor hook register-custom-fields sent bad data: @$op"; + } +} + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/FieldsCore.pm b/scripts/Dpkg/Control/FieldsCore.pm new file mode 100644 index 0000000..0c024ab --- /dev/null +++ b/scripts/Dpkg/Control/FieldsCore.pm @@ -0,0 +1,1387 @@ +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::FieldsCore - manage (list of official) control fields + +=head1 DESCRIPTION + +The modules contains a list of field names with associated meta-data explaining +in which type of control information they are allowed. The types are the +CTRL_* constants exported by L<Dpkg::Control>. + +=cut + +package Dpkg::Control::FieldsCore 1.02; + +use strict; +use warnings; + +our @EXPORT = qw( + field_capitalize + field_is_official + field_is_allowed_in + field_transfer_single + field_transfer_all + field_parse_binary_source + field_list_src_dep + field_list_pkg_dep + field_get_dep_type + field_get_sep_type + field_ordered_list + field_register + field_insert_after + field_insert_before + FIELD_SEP_UNKNOWN + FIELD_SEP_SPACE + FIELD_SEP_COMMA + FIELD_SEP_LINE +); + +use Exporter qw(import); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control::Types; + +use constant { + ALL_PKG => CTRL_TMPL_PKG | CTRL_REPO_PKG | CTRL_DEB | CTRL_FILE_STATUS, + ALL_SRC => CTRL_TMPL_SRC | CTRL_REPO_SRC | CTRL_DSC, + ALL_FILE_MANIFEST => CTRL_FILE_BUILDINFO | CTRL_FILE_CHANGES, + ALL_CHANGES => CTRL_FILE_CHANGES | CTRL_CHANGELOG, + ALL_COPYRIGHT => CTRL_COPYRIGHT_HEADER | CTRL_COPYRIGHT_FILES | CTRL_COPYRIGHT_LICENSE, +}; + +use constant { + FIELD_SEP_UNKNOWN => 0, + FIELD_SEP_SPACE => 1, + FIELD_SEP_COMMA => 2, + FIELD_SEP_LINE => 4, +}; + +# The canonical list of fields. + +# Note that fields used only in dpkg's available file are not listed. +# Deprecated fields of dpkg's status file are also not listed. +our %FIELDS = ( + 'acquire-by-hash' => { + name => 'Acquire-By-Hash', + allowed => CTRL_REPO_RELEASE, + }, + 'architecture' => { + name => 'Architecture', + allowed => (ALL_PKG | ALL_SRC | ALL_FILE_MANIFEST | CTRL_TESTS) & (~CTRL_TMPL_SRC), + separator => FIELD_SEP_SPACE, + }, + 'architectures' => { + name => 'Architectures', + allowed => CTRL_REPO_RELEASE, + separator => FIELD_SEP_SPACE, + }, + 'auto-built-package' => { + name => 'Auto-Built-Package', + allowed => ALL_PKG & ~CTRL_TMPL_PKG, + separator => FIELD_SEP_SPACE, + }, + 'binary' => { + name => 'Binary', + allowed => CTRL_DSC | CTRL_REPO_SRC | ALL_FILE_MANIFEST, + # XXX: This field values are separated either by space or comma + # depending on the context. + separator => FIELD_SEP_SPACE | FIELD_SEP_COMMA, + }, + 'binary-only' => { + name => 'Binary-Only', + allowed => ALL_CHANGES, + }, + 'binary-only-changes' => { + name => 'Binary-Only-Changes', + allowed => CTRL_FILE_BUILDINFO, + }, + 'breaks' => { + name => 'Breaks', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 7, + }, + 'bugs' => { + name => 'Bugs', + allowed => (ALL_PKG | CTRL_TMPL_SRC | CTRL_FILE_VENDOR) & (~CTRL_TMPL_PKG), + }, + 'build-architecture' => { + name => 'Build-Architecture', + allowed => CTRL_FILE_BUILDINFO, + }, + 'build-conflicts' => { + name => 'Build-Conflicts', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 4, + }, + 'build-conflicts-arch' => { + name => 'Build-Conflicts-Arch', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 5, + }, + 'build-conflicts-indep' => { + name => 'Build-Conflicts-Indep', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 6, + }, + 'build-date' => { + name => 'Build-Date', + allowed => CTRL_FILE_BUILDINFO, + }, + 'build-depends' => { + name => 'Build-Depends', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 1, + }, + 'build-depends-arch' => { + name => 'Build-Depends-Arch', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 2, + }, + 'build-depends-indep' => { + name => 'Build-Depends-Indep', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 3, + }, + 'build-essential' => { + name => 'Build-Essential', + allowed => ALL_PKG, + }, + 'build-kernel-version' => { + name => 'Build-Kernel-Version', + allowed => CTRL_FILE_BUILDINFO, + }, + 'build-origin' => { + name => 'Build-Origin', + allowed => CTRL_FILE_BUILDINFO, + }, + 'build-path' => { + name => 'Build-Path', + allowed => CTRL_FILE_BUILDINFO, + }, + 'build-profiles' => { + name => 'Build-Profiles', + allowed => CTRL_TMPL_PKG, + separator => FIELD_SEP_SPACE, + }, + 'build-tainted-by' => { + name => 'Build-Tainted-By', + allowed => CTRL_FILE_BUILDINFO, + separator => FIELD_SEP_SPACE, + }, + 'built-for-profiles' => { + name => 'Built-For-Profiles', + allowed => ALL_PKG | CTRL_FILE_CHANGES, + separator => FIELD_SEP_SPACE, + }, + 'built-using' => { + name => 'Built-Using', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 10, + }, + 'butautomaticupgrades' => { + name => 'ButAutomaticUpgrades', + allowed => CTRL_REPO_RELEASE, + }, + 'changed-by' => { + name => 'Changed-By', + allowed => CTRL_FILE_CHANGES, + }, + 'changelogs' => { + name => 'Changelogs', + allowed => CTRL_REPO_RELEASE, + }, + 'changes' => { + name => 'Changes', + allowed => ALL_CHANGES, + }, + 'checksums-md5' => { + name => 'Checksums-Md5', + allowed => CTRL_DSC | CTRL_REPO_SRC | ALL_FILE_MANIFEST, + }, + 'checksums-sha1' => { + name => 'Checksums-Sha1', + allowed => CTRL_DSC | CTRL_REPO_SRC | ALL_FILE_MANIFEST, + }, + 'checksums-sha256' => { + name => 'Checksums-Sha256', + allowed => CTRL_DSC | CTRL_REPO_SRC | ALL_FILE_MANIFEST, + }, + 'classes' => { + name => 'Classes', + allowed => CTRL_TESTS, + separator => FIELD_SEP_COMMA, + }, + 'closes' => { + name => 'Closes', + allowed => ALL_CHANGES, + separator => FIELD_SEP_SPACE, + }, + 'codename' => { + name => 'Codename', + allowed => CTRL_REPO_RELEASE, + }, + 'comment' => { + name => 'Comment', + allowed => ALL_COPYRIGHT, + }, + 'components' => { + name => 'Components', + allowed => CTRL_REPO_RELEASE, + separator => FIELD_SEP_SPACE, + }, + 'conffiles' => { + name => 'Conffiles', + allowed => CTRL_FILE_STATUS, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'config-version' => { + name => 'Config-Version', + allowed => CTRL_FILE_STATUS, + }, + 'conflicts' => { + name => 'Conflicts', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 6, + }, + 'copyright' => { + name => 'Copyright', + allowed => CTRL_COPYRIGHT_HEADER | CTRL_COPYRIGHT_FILES, + }, + 'date' => { + name => 'Date', + allowed => ALL_CHANGES | CTRL_REPO_RELEASE, + }, + 'depends' => { + name => 'Depends', + allowed => ALL_PKG | CTRL_TESTS, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 2, + }, + 'description' => { + name => 'Description', + allowed => ALL_SRC | ALL_PKG | CTRL_FILE_CHANGES | CTRL_REPO_RELEASE, + }, + 'disclaimer' => { + name => 'Disclaimer', + allowed => CTRL_COPYRIGHT_HEADER, + }, + 'directory' => { + name => 'Directory', + allowed => CTRL_REPO_SRC, + }, + 'distribution' => { + name => 'Distribution', + allowed => ALL_CHANGES, + }, + 'enhances' => { + name => 'Enhances', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 5, + }, + 'environment' => { + name => 'Environment', + allowed => CTRL_FILE_BUILDINFO, + separator => FIELD_SEP_LINE, + }, + 'essential' => { + name => 'Essential', + allowed => ALL_PKG, + }, + 'features' => { + name => 'Features', + allowed => CTRL_TESTS, + separator => FIELD_SEP_SPACE, + }, + 'filename' => { + name => 'Filename', + allowed => CTRL_REPO_PKG, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'files' => { + name => 'Files', + allowed => CTRL_DSC | CTRL_REPO_SRC | CTRL_FILE_CHANGES | CTRL_COPYRIGHT_FILES, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'format' => { + name => 'Format', + allowed => CTRL_DSC | CTRL_REPO_SRC | ALL_FILE_MANIFEST | CTRL_COPYRIGHT_HEADER, + }, + 'homepage' => { + name => 'Homepage', + allowed => ALL_SRC | ALL_PKG, + }, + 'installed-build-depends' => { + name => 'Installed-Build-Depends', + allowed => CTRL_FILE_BUILDINFO, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 12, + }, + 'installed-size' => { + name => 'Installed-Size', + allowed => ALL_PKG & ~CTRL_TMPL_PKG, + }, + 'installer-menu-item' => { + name => 'Installer-Menu-Item', + allowed => ALL_PKG, + }, + 'kernel-version' => { + name => 'Kernel-Version', + allowed => ALL_PKG, + }, + 'label' => { + name => 'Label', + allowed => CTRL_REPO_RELEASE, + }, + 'license' => { + name => 'License', + allowed => ALL_COPYRIGHT, + }, + 'origin' => { + name => 'Origin', + allowed => (ALL_PKG | ALL_SRC | CTRL_REPO_RELEASE) & (~CTRL_TMPL_PKG), + }, + 'maintainer' => { + name => 'Maintainer', + allowed => CTRL_DEB | CTRL_REPO_PKG | CTRL_FILE_STATUS | ALL_SRC | ALL_CHANGES, + }, + 'md5sum' => { + # XXX: Wrong capitalization due to historical reasons. + name => 'MD5sum', + allowed => CTRL_REPO_PKG | CTRL_REPO_RELEASE, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'multi-arch' => { + name => 'Multi-Arch', + allowed => ALL_PKG, + }, + 'no-support-for-architecture-all' => { + name => 'No-Support-for-Architecture-all', + allowed => CTRL_REPO_RELEASE, + }, + 'notautomatic' => { + name => 'NotAutomatic', + allowed => CTRL_REPO_RELEASE, + }, + 'package' => { + name => 'Package', + allowed => ALL_PKG | CTRL_REPO_SRC, + }, + 'package-list' => { + name => 'Package-List', + allowed => ALL_SRC & ~CTRL_TMPL_SRC, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'package-type' => { + name => 'Package-Type', + allowed => ALL_PKG, + }, + 'parent' => { + name => 'Parent', + allowed => CTRL_FILE_VENDOR, + }, + 'pre-depends' => { + name => 'Pre-Depends', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 1, + }, + 'priority' => { + name => 'Priority', + allowed => CTRL_TMPL_SRC | CTRL_REPO_SRC | ALL_PKG, + }, + 'protected' => { + name => 'Protected', + allowed => ALL_PKG, + }, + 'provides' => { + name => 'Provides', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 9, + }, + 'recommends' => { + name => 'Recommends', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 3, + }, + 'replaces' => { + name => 'Replaces', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 8, + }, + 'restrictions' => { + name => 'Restrictions', + allowed => CTRL_TESTS, + separator => FIELD_SEP_SPACE, + }, + 'rules-requires-root' => { + name => 'Rules-Requires-Root', + allowed => CTRL_TMPL_SRC, + separator => FIELD_SEP_SPACE, + }, + 'section' => { + name => 'Section', + allowed => CTRL_TMPL_SRC | CTRL_REPO_SRC | ALL_PKG, + }, + 'sha1' => { + # XXX: Wrong capitalization due to historical reasons. + name => 'SHA1', + allowed => CTRL_REPO_PKG | CTRL_REPO_RELEASE, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'sha256' => { + # XXX: Wrong capitalization due to historical reasons. + name => 'SHA256', + allowed => CTRL_REPO_PKG | CTRL_REPO_RELEASE, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'size' => { + name => 'Size', + allowed => CTRL_REPO_PKG, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'source' => { + name => 'Source', + allowed => (ALL_PKG | ALL_SRC | ALL_CHANGES | CTRL_COPYRIGHT_HEADER | CTRL_FILE_BUILDINFO) & + (~(CTRL_REPO_SRC | CTRL_TMPL_PKG)), + }, + 'standards-version' => { + name => 'Standards-Version', + allowed => ALL_SRC, + }, + 'static-built-using' => { + name => 'Static-Built-Using', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 11, + }, + 'status' => { + name => 'Status', + allowed => CTRL_FILE_STATUS, + separator => FIELD_SEP_SPACE, + }, + 'subarchitecture' => { + name => 'Subarchitecture', + allowed => ALL_PKG, + }, + 'suite' => { + name => 'Suite', + allowed => CTRL_REPO_RELEASE, + }, + 'suggests' => { + name => 'Suggests', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 4, + }, + 'tag' => { + name => 'Tag', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + }, + 'task' => { + name => 'Task', + allowed => ALL_PKG, + }, + 'test-command' => { + name => 'Test-Command', + allowed => CTRL_TESTS, + }, + 'tests' => { + name => 'Tests', + allowed => CTRL_TESTS, + separator => FIELD_SEP_SPACE, + }, + 'tests-directory' => { + name => 'Tests-Directory', + allowed => CTRL_TESTS, + }, + 'testsuite' => { + name => 'Testsuite', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + }, + 'testsuite-triggers' => { + name => 'Testsuite-Triggers', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + }, + 'timestamp' => { + name => 'Timestamp', + allowed => CTRL_CHANGELOG, + }, + 'triggers-awaited' => { + name => 'Triggers-Awaited', + allowed => CTRL_FILE_STATUS, + separator => FIELD_SEP_SPACE, + }, + 'triggers-pending' => { + name => 'Triggers-Pending', + allowed => CTRL_FILE_STATUS, + separator => FIELD_SEP_SPACE, + }, + 'uploaders' => { + name => 'Uploaders', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + }, + 'upstream-name' => { + name => 'Upstream-Name', + allowed => CTRL_COPYRIGHT_HEADER, + }, + 'upstream-contact' => { + name => 'Upstream-Contact', + allowed => CTRL_COPYRIGHT_HEADER, + }, + 'urgency' => { + name => 'Urgency', + allowed => ALL_CHANGES, + }, + 'valid-until' => { + name => 'Valid-Until', + allowed => CTRL_REPO_RELEASE, + }, + 'vcs-browser' => { + name => 'Vcs-Browser', + allowed => ALL_SRC, + }, + 'vcs-arch' => { + name => 'Vcs-Arch', + allowed => ALL_SRC, + }, + 'vcs-bzr' => { + name => 'Vcs-Bzr', + allowed => ALL_SRC, + }, + 'vcs-cvs' => { + name => 'Vcs-Cvs', + allowed => ALL_SRC, + }, + 'vcs-darcs' => { + name => 'Vcs-Darcs', + allowed => ALL_SRC, + }, + 'vcs-git' => { + name => 'Vcs-Git', + allowed => ALL_SRC, + }, + 'vcs-hg' => { + name => 'Vcs-Hg', + allowed => ALL_SRC, + }, + 'vcs-mtn' => { + name => 'Vcs-Mtn', + allowed => ALL_SRC, + }, + 'vcs-svn' => { + name => 'Vcs-Svn', + allowed => ALL_SRC, + }, + 'vendor' => { + name => 'Vendor', + allowed => CTRL_FILE_VENDOR, + }, + 'vendor-url' => { + name => 'Vendor-Url', + allowed => CTRL_FILE_VENDOR, + }, + 'version' => { + name => 'Version', + allowed => (ALL_PKG | ALL_SRC | CTRL_FILE_BUILDINFO | ALL_CHANGES | CTRL_REPO_RELEASE) & + (~(CTRL_TMPL_SRC | CTRL_TMPL_PKG)), + }, +); + +my @src_vcs_fields = qw( + vcs-browser + vcs-arch + vcs-bzr + vcs-cvs + vcs-darcs + vcs-git + vcs-hg + vcs-mtn + vcs-svn +); + +my @src_dep_fields = qw( + build-depends + build-depends-arch + build-depends-indep + build-conflicts + build-conflicts-arch + build-conflicts-indep +); +my @bin_dep_fields = qw( + pre-depends + depends + recommends + suggests + enhances + conflicts + breaks + replaces + provides + built-using + static-built-using +); + +my @src_test_fields = qw( + testsuite + testsuite-triggers +); + +my @src_checksums_fields = qw( + checksums-md5 + checksums-sha1 + checksums-sha256 +); +my @bin_checksums_fields = qw( + md5sum + sha1 + sha256 +); + +our %FIELD_ORDER = ( + CTRL_TMPL_SRC() => [ + qw( + source + section + priority + maintainer + uploaders + origin + bugs + ), + @src_vcs_fields, + qw( + homepage + standards-version + rules-requires-root + ), + @src_dep_fields, + @src_test_fields, + qw( + description + ), + ], + CTRL_TMPL_PKG() => [ + qw( + package + package-type + section + priority + architecture + subarchitecture + multi-arch + essential + protected + build-essential + build-profiles + built-for-profiles + kernel-version + ), + @bin_dep_fields, + qw( + homepage + installer-menu-item + task + tag + description + ), + ], + CTRL_DSC() => [ + qw( + format + source + binary + architecture + version + origin + maintainer + uploaders + homepage + description + standards-version + ), + @src_vcs_fields, + @src_test_fields, + @src_dep_fields, + qw( + package-list + ), + @src_checksums_fields, + qw( + files + ), + ], + CTRL_DEB() => [ + qw( + package + package-type + source + version + kernel-version + built-for-profiles + auto-built-package + architecture + subarchitecture + installer-menu-item + build-essential + essential + protected + origin + bugs + maintainer + installed-size + ), + @bin_dep_fields, + qw( + section + priority + multi-arch + homepage + description + tag + task + ), + ], + CTRL_REPO_SRC() => [ + qw( + format + package + binary + architecture + version + priority + section + origin + maintainer + uploaders + homepage + description + standards-version + ), + @src_vcs_fields, + @src_test_fields, + @src_dep_fields, + qw( + package-list + directory + ), + @src_checksums_fields, + qw( + files + ), + ], + CTRL_REPO_PKG() => [ + qw( + package + package-type + source + version + kernel-version + built-for-profiles + auto-built-package + architecture + subarchitecture + installer-menu-item + build-essential + essential + protected + origin + bugs + maintainer + installed-size + ), + @bin_dep_fields, + qw( + filename + size + ), + @bin_checksums_fields, + qw( + section + priority + multi-arch + homepage + description + tag + task + ), + ], + CTRL_REPO_RELEASE() => [ + qw( + origin + label + suite + version + codename + changelogs + date + valid-until + notautomatic + butautomaticupgrades + acquire-by-hash + no-support-for-architecture-all + architectures + components + description + ), + @bin_checksums_fields + ], + CTRL_CHANGELOG() => [ + qw( + source + binary-only + version + distribution + urgency + maintainer + timestamp + date + closes + changes + ), + ], + CTRL_COPYRIGHT_HEADER() => [ + qw( + format + upstream-name + upstream-contact + source + disclaimer + comment + license + copyright + ), + ], + CTRL_COPYRIGHT_FILES() => [ + qw( + files + copyright + license + comment + ), + ], + CTRL_COPYRIGHT_LICENSE() => [ + qw( + license + comment + ), + ], + CTRL_FILE_BUILDINFO() => [ + qw( + format + source + binary + architecture + version + binary-only-changes + ), + @src_checksums_fields, + qw( + build-origin + build-architecture + build-kernel-version + build-date + build-path + build-tainted-by + installed-build-depends + environment + ), + ], + CTRL_FILE_CHANGES() => [ + qw( + format + date + source + binary + binary-only + built-for-profiles + architecture + version + distribution + urgency + maintainer + changed-by + description + closes + changes + ), + @src_checksums_fields, + qw( + files + ), + ], + CTRL_FILE_VENDOR() => [ + qw( + vendor + vendor-url + bugs + parent + ), + ], + CTRL_FILE_STATUS() => [ + # Same as fieldinfos in lib/dpkg/parse.c + qw( + package + essential + protected + status + priority + section + installed-size + origin + maintainer + bugs + architecture + multi-arch + source + version + config-version + replaces + provides + depends + pre-depends + recommends + suggests + breaks + conflicts + enhances + conffiles + description + triggers-pending + triggers-awaited + ), + # These are allowed here, but not tracked by lib/dpkg/parse.c. + qw( + auto-built-package + build-essential + built-for-profiles + built-using + static-built-using + homepage + installer-menu-item + kernel-version + package-type + subarchitecture + tag + task + ), + ], + CTRL_TESTS() => [ + qw( + test-command + tests + tests-directory + architecture + restrictions + features + classes + depends + ), + ], +); + +=head1 FUNCTIONS + +=over 4 + +=item $f = field_capitalize($field_name) + +Returns the field name properly capitalized. All characters are lowercase, +except the first of each word (words are separated by a hyphen in field names). + +=cut + +sub field_capitalize($) { + my $field = lc(shift); + + # Use known fields first. + return $FIELDS{$field}{name} if exists $FIELDS{$field}; + + # Generic case + return join '-', map { ucfirst } split /-/, $field; +} + +=item $bool = field_is_official($fname) + +Returns true if the field is official and known. + +=cut + +sub field_is_official($) { + my $field = lc shift; + + return exists $FIELDS{$field}; +} + +=item $bool = field_is_allowed_in($fname, @types) + +Returns true (1) if the field $fname is allowed in all the types listed in +the list. Note that you can use type sets instead of individual types (ex: +CTRL_FILE_CHANGES | CTRL_CHANGELOG). + +field_allowed_in(A|B, C) returns true only if the field is allowed in C +and either A or B. + +Undef is returned for non-official fields. + +=cut + +sub field_is_allowed_in($@) { + my ($field, @types) = @_; + $field = lc $field; + + return unless exists $FIELDS{$field}; + + return 0 if not scalar(@types); + foreach my $type (@types) { + next if $type == CTRL_UNKNOWN; # Always allowed + return 0 unless $FIELDS{$field}{allowed} & $type; + } + return 1; +} + +=item $new_field = field_transfer_single($from, $to, $field) + +If appropriate, copy the value of the field named $field taken from the +$from L<Dpkg::Control> object to the $to L<Dpkg::Control> object. + +Official fields are copied only if the field is allowed in both types of +objects. Custom fields are treated in a specific manner. When the target +is not among CTRL_DSC, CTRL_DEB or CTRL_FILE_CHANGES, then they +are always copied as is (the X- prefix is kept). Otherwise they are not +copied except if the target object matches the target destination encoded +in the field name. The initial X denoting custom fields can be followed by +one or more letters among "S" (Source: corresponds to CTRL_DSC), "B" +(Binary: corresponds to CTRL_DEB) or "C" (Changes: corresponds to +CTRL_FILE_CHANGES). + +Returns undef if nothing has been copied or the name of the new field +added to $to otherwise. + +=cut + +sub field_transfer_single($$;$) { + my ($from, $to, $field) = @_; + if (not defined $field) { + warnings::warnif('deprecated', + 'using Dpkg::Control::Fields::field_transfer_single() with an ' . + 'an implicit field argument is deprecated'); + $field = $_; + } + my ($from_type, $to_type) = ($from->get_type(), $to->get_type()); + $field = field_capitalize($field); + + if (field_is_allowed_in($field, $from_type, $to_type)) { + $to->{$field} = $from->{$field}; + return $field; + } elsif ($field =~ /^X([SBC]*)-/i) { + my $dest = $1; + if (($dest =~ /B/i and $to_type == CTRL_DEB) or + ($dest =~ /S/i and $to_type == CTRL_DSC) or + ($dest =~ /C/i and $to_type == CTRL_FILE_CHANGES)) + { + my $new = $field; + $new =~ s/^X([SBC]*)-//i; + $to->{$new} = $from->{$field}; + return $new; + } elsif ($to_type != CTRL_DEB and + $to_type != CTRL_DSC and + $to_type != CTRL_FILE_CHANGES) + { + $to->{$field} = $from->{$field}; + return $field; + } + } elsif (not field_is_allowed_in($field, $from_type)) { + warning(g_("unknown information field '%s' in input data in %s"), + $field, $from->get_option('name') || g_('control information')); + } + return; +} + +=item @field_list = field_transfer_all($from, $to) + +Transfer all appropriate fields from $from to $to. Calls +field_transfer_single() on all fields available in $from. + +Returns the list of fields that have been added to $to. + +=cut + +sub field_transfer_all($$) { + my ($from, $to) = @_; + my (@res, $res); + foreach my $k (keys %$from) { + $res = field_transfer_single($from, $to, $k); + push @res, $res if $res and defined wantarray; + } + return @res; +} + +=item @field_list = field_ordered_list($type) + +Returns an ordered list of fields for a given type of control information. +This list can be used to output the fields in a predictable order. +The list might be empty for types where the order does not matter much. + +=cut + +sub field_ordered_list($) { + my $type = shift; + + if (exists $FIELD_ORDER{$type}) { + return map { $FIELDS{$_}{name} } @{$FIELD_ORDER{$type}}; + } + return (); +} + +=item ($source, $version) = field_parse_binary_source($ctrl) + +Parse the B<Source> field in a binary package control stanza. The field +contains the source package name where it was built from, and optionally +a space and the source version enclosed in parenthesis if it is different +from the binary version. + +Returns a list with the $source name, and the source $version, or undef +or an empty list when $ctrl does not contain a binary package control stanza. +Neither $source nor $version are validated, but that can be done with +Dpkg::Package::pkg_name_is_illegal() and Dpkg::Version::version_check(). + +=cut + +sub field_parse_binary_source($) { + my $ctrl = shift; + my $ctrl_type = $ctrl->get_type(); + + if ($ctrl_type != CTRL_REPO_PKG and + $ctrl_type != CTRL_DEB and + $ctrl_type != CTRL_FILE_CHANGES and + $ctrl_type != CTRL_FILE_BUILDINFO and + $ctrl_type != CTRL_FILE_STATUS) { + return; + } + + my ($source, $version); + + # For .changes and .buildinfo the Source field always exists, + # and there is no Package field. + if (exists $ctrl->{'Source'}) { + $source = $ctrl->{'Source'}; + if ($source =~ m/^([^ ]+) +\(([^)]*)\)$/) { + $source = $1; + $version = $2; + } else { + $version = $ctrl->{'Version'}; + } + } else { + $source = $ctrl->{'Package'}; + $version = $ctrl->{'Version'}; + } + + return ($source, $version); +} + +=item @field_list = field_list_src_dep() + +List of fields that contains dependencies-like information in a source +Debian package. + +=cut + +sub field_list_src_dep() { + my @list = map { + $FIELDS{$_}{name} + } sort { + $FIELDS{$a}{dep_order} <=> $FIELDS{$b}{dep_order} + } grep { + field_is_allowed_in($_, CTRL_DSC) and + exists $FIELDS{$_}{dependency} + } keys %FIELDS; + return @list; +} + +=item @field_list = field_list_pkg_dep() + +List of fields that contains dependencies-like information in a binary +Debian package. The fields that express real dependencies are sorted from +the stronger to the weaker. + +=cut + +sub field_list_pkg_dep() { + my @list = map { + $FIELDS{$_}{name} + } sort { + $FIELDS{$a}{dep_order} <=> $FIELDS{$b}{dep_order} + } grep { + field_is_allowed_in($_, CTRL_DEB) and + exists $FIELDS{$_}{dependency} + } keys %FIELDS; + return @list; +} + +=item $dep_type = field_get_dep_type($field) + +Return the type of the dependency expressed by the given field. Can +either be "normal" for a real dependency field (Pre-Depends, Depends, ...) +or "union" for other relation fields sharing the same syntax (Conflicts, +Breaks, ...). Returns undef for fields which are not dependencies. + +=cut + +sub field_get_dep_type($) { + my $field = lc shift; + + return unless exists $FIELDS{$field}; + return $FIELDS{$field}{dependency} if exists $FIELDS{$field}{dependency}; + return; +} + +=item $sep_type = field_get_sep_type($field) + +Return the type of the field value separator. Can be one of FIELD_SEP_UNKNOWN, +FIELD_SEP_SPACE, FIELD_SEP_COMMA or FIELD_SEP_LINE. + +=cut + +sub field_get_sep_type($) { + my $field = lc shift; + + return $FIELDS{$field}{separator} if exists $FIELDS{$field}{separator}; + return FIELD_SEP_UNKNOWN; +} + +=item field_register($field, $allowed_types, %opts) + +Register a new field as being allowed in control information of specified +types. %opts is optional. + +=cut + +sub field_register($$;@) { + my ($field, $types, %opts) = @_; + + $field = lc $field; + $FIELDS{$field} = { + name => field_capitalize($field), + allowed => $types, + %opts + }; + + return; +} + +=item $bool = field_insert_after($type, $ref, @fields) + +Place field after another one ($ref) in output of control information of +type $type. + +Return true if the field was inserted, otherwise false. + +=cut + +sub field_insert_after($$@) { + my ($type, $field, @fields) = @_; + + return 0 if not exists $FIELD_ORDER{$type}; + + ($field, @fields) = map { lc } ($field, @fields); + @{$FIELD_ORDER{$type}} = map { + ($_ eq $field) ? ($_, @fields) : $_ + } @{$FIELD_ORDER{$type}}; + + return 1; +} + +=item $bool = field_insert_before($type, $ref, @fields) + +Place field before another one ($ref) in output of control information of +type $type. + +Return true if the field was inserted, otherwise false. + +=cut + +sub field_insert_before($$@) { + my ($type, $field, @fields) = @_; + + return 0 if not exists $FIELD_ORDER{$type}; + + ($field, @fields) = map { lc } ($field, @fields); + @{$FIELD_ORDER{$type}} = map { + ($_ eq $field) ? (@fields, $_) : $_ + } @{$FIELD_ORDER{$type}}; + + return 1; +} + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.22.0) + +Deprecate argument: field_transfer_single() implicit argument usage. + +=head2 Version 1.01 (dpkg 1.21.0) + +New function: field_parse_binary_source(). + +=head2 Version 1.00 (dpkg 1.17.0) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Hash.pm b/scripts/Dpkg/Control/Hash.pm new file mode 100644 index 0000000..5530113 --- /dev/null +++ b/scripts/Dpkg/Control/Hash.pm @@ -0,0 +1,48 @@ +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Hash - parse and manipulate a stanza of deb822 fields + +=head1 DESCRIPTION + +This module is just like L<Dpkg::Control::HashCore>, with vendor-specific +field knowledge. + +=cut + +package Dpkg::Control::Hash 1.00; + +use strict; +use warnings; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control::Fields; # Force execution of vendor hook. + +use parent qw(Dpkg::Control::HashCore); + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/HashCore.pm b/scripts/Dpkg/Control/HashCore.pm new file mode 100644 index 0000000..b58fc66 --- /dev/null +++ b/scripts/Dpkg/Control/HashCore.pm @@ -0,0 +1,486 @@ +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2009, 2012-2019, 2021 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::HashCore - parse and manipulate a stanza of deb822 fields + +=head1 DESCRIPTION + +The L<Dpkg::Control::Hash> class is a hash-like representation of a set of +RFC822-like fields. The fields names are case insensitive and are always +capitalized the same when output (see field_capitalize() function in +L<Dpkg::Control::Fields>). +The order in which fields have been set is remembered and is used +to be able to dump back the same content. The output order can also be +overridden if needed. + +You can store arbitrary values in the hash, they will always be properly +escaped in the output to conform to the syntax of control files. This is +relevant mainly for multilines values: while the first line is always output +unchanged directly after the field name, supplementary lines are +modified. Empty lines and lines containing only dots are prefixed with +" ." (space + dot) while other lines are prefixed with a single space. + +During parsing, trailing spaces are stripped on all lines while leading +spaces are stripped only on the first line of each field. + +=cut + +package Dpkg::Control::HashCore 1.02; + +use strict; +use warnings; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control::FieldsCore; +use Dpkg::Control::HashCore::Tie; + +# This module cannot use Dpkg::Control::Fields, because that one makes use +# of Dpkg::Vendor which at the same time uses this module, which would turn +# into a compilation error. We can use Dpkg::Control::FieldsCore instead. + +use parent qw(Dpkg::Interface::Storable); + +use overload + '%{}' => sub { ${$_[0]}->{fields} }, + 'eq' => sub { "$_[0]" eq "$_[1]" }; + +=head1 METHODS + +=over 4 + +=item $c = Dpkg::Control::Hash->new(%opts) + +Creates a new object with the indicated options. Supported options +are: + +=over 8 + +=item allow_pgp + +Configures the parser to accept OpenPGP signatures around the control +information. Value can be 0 (default) or 1. + +=item allow_duplicate + +Configures the parser to allow duplicate fields in the control +information. +The last value overrides any previous values. +Value can be 0 (default) or 1. + +=item keep_duplicate + +Configure the parser to keep values for duplicate fields found in the control +information (when B<allow_duplicate> is enabled), as array references. +Value can be 0 (default) or 1. + +=item drop_empty + +Defines if empty fields are dropped during the output. Value can be 0 +(default) or 1. + +=item name + +The user friendly name of the information stored in the object. It might +be used in some error messages or warnings. A default name might be set +depending on the type. + +=item is_pgp_signed + +Set by the parser (starting in dpkg 1.17.0) if it finds an OpenPGP +signature around the control information. Value can be 0 (default) +or 1, and undef when the option is not supported by the code (in +versions older than dpkg 1.17.0). + +=back + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + # Object is a scalar reference and not a hash ref to avoid + # infinite recursion due to overloading hash-dereferencing + my $self = \{ + in_order => [], + out_order => [], + is_pgp_signed => 0, + allow_pgp => 0, + allow_duplicate => 0, + keep_duplicate => 0, + drop_empty => 0, + }; + bless $self, $class; + + $$self->{fields} = Dpkg::Control::HashCore::Tie->new($self); + + # Options set by the user override default values + $$self->{$_} = $opts{$_} foreach keys %opts; + + return $self; +} + +# There is naturally a circular reference between the tied hash and its +# containing object. Happily, the extra layer of scalar reference can +# be used to detect the destruction of the object and break the loop so +# that everything gets garbage-collected. + +sub DESTROY { + my $self = shift; + delete $$self->{fields}; +} + +=item $c->set_options($option, %opts) + +Changes the value of one or more options. + +=cut + +sub set_options { + my ($self, %opts) = @_; + $$self->{$_} = $opts{$_} foreach keys %opts; +} + +=item $value = $c->get_option($option) + +Returns the value of the corresponding option. + +=cut + +sub get_option { + my ($self, $k) = @_; + return $$self->{$k}; +} + +=item $c->parse_error($file, $fmt, ...) + +Prints an error message and dies on syntax parse errors. + +=cut + +sub parse_error { + my ($self, $file, $msg, @args) = @_; + + $msg = sprintf $msg, @args if @args; + error(g_('syntax error in %s at line %d: %s'), $file, $., $msg); +} + +=item $c->parse($fh, $description) + +Parse a control file from the given filehandle. Exits in case of errors. +$description is used to describe the filehandle, ideally it's a filename +or a description of where the data comes from. It's used in error +messages. When called multiple times, the parsed fields are accumulated. + +Returns true if some fields have been parsed. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + + my $paraborder = 1; + my $parabody = 0; + my $cf; # Current field + my $expect_pgp_sig = 0; + local $_; + + while (<$fh>) { + # In the common case there will be just a trailing \n character, + # so using chomp here which is very fast will avoid the latter + # s/// doing anything, which gives us a significant speed up. + chomp; + my $armor = $_; + s/\s+$//; + + next if length == 0 and $paraborder; + + my $lead = substr $_, 0, 1; + next if $lead eq '#'; + $paraborder = 0; + + my ($name, $value) = split /\s*:\s*/, $_, 2; + if (defined $name and $name =~ m/^\S+?$/) { + $parabody = 1; + if ($lead eq '-') { + $self->parse_error($desc, g_('field cannot start with a hyphen')); + } + if (exists $self->{$name}) { + unless ($$self->{allow_duplicate}) { + $self->parse_error($desc, g_('duplicate field %s found'), $name); + } + if ($$self->{keep_duplicate}) { + if (ref $self->{$name} ne 'ARRAY') { + # Switch value into an array. + $self->{$name} = [ $self->{$name}, $value ]; + } else { + # Append the value. + push @{$self->{$name}}, $value; + } + } else { + # Overwrite with last value. + $self->{$name} = $value; + } + } else { + $self->{$name} = $value; + } + $cf = $name; + } elsif (m/^\s(\s*\S.*)$/) { + my $line = $1; + unless (defined($cf)) { + $self->parse_error($desc, g_('continued value line not in field')); + } + if ($line =~ /^\.+$/) { + $line = substr $line, 1; + } + $self->{$cf} .= "\n$line"; + } elsif (length == 0 || + ($expect_pgp_sig && $armor =~ m/^-----BEGIN PGP SIGNATURE-----[\r\t ]*$/)) { + if ($expect_pgp_sig) { + # Skip empty lines + $_ = <$fh> while defined && m/^\s*$/; + unless (length) { + $self->parse_error($desc, g_('expected OpenPGP signature, ' . + 'found end of file after blank line')); + } + chomp; + unless (m/^-----BEGIN PGP SIGNATURE-----[\r\t ]*$/) { + $self->parse_error($desc, g_('expected OpenPGP signature, ' . + "found something else '%s'"), $_); + } + # Skip OpenPGP signature + while (<$fh>) { + chomp; + last if m/^-----END PGP SIGNATURE-----[\r\t ]*$/; + } + unless (defined) { + $self->parse_error($desc, g_('unfinished OpenPGP signature')); + } + # This does not mean the signature is correct, that needs to + # be verified by an OpenPGP backend. + $$self->{is_pgp_signed} = 1; + } + # Finished parsing one stanza. + last; + } elsif ($armor =~ m/^-----BEGIN PGP SIGNED MESSAGE-----[\r\t ]*$/) { + $expect_pgp_sig = 1; + if ($$self->{allow_pgp} and not $parabody) { + # Skip OpenPGP headers + while (<$fh>) { + last if m/^\s*$/; + } + } else { + $self->parse_error($desc, g_('OpenPGP signature not allowed here')); + } + } else { + $self->parse_error($desc, + g_('line with unknown format (not field-colon-value)')); + } + } + + if ($expect_pgp_sig and not $$self->{is_pgp_signed}) { + $self->parse_error($desc, g_('unfinished OpenPGP signature')); + } + + return defined($cf); +} + +=item $c->load($file) + +Parse the content of $file. Exits in case of errors. Returns true if some +fields have been parsed. + +=item $c->find_custom_field($name) + +Scan the fields and look for a user specific field whose name matches the +following regex: /X[SBC]*-$name/i. Return the name of the field found or +undef if nothing has been found. + +=cut + +sub find_custom_field { + my ($self, $name) = @_; + foreach my $key (keys %$self) { + return $key if $key =~ /^X[SBC]*-\Q$name\E$/i; + } + return; +} + +=item $c->get_custom_field($name) + +Identify a user field and retrieve its value. + +=cut + +sub get_custom_field { + my ($self, $name) = @_; + my $key = $self->find_custom_field($name); + return $self->{$key} if defined $key; + return; +} + +=item $str = $c->output() + +=item "$c" + +Get a string representation of the control information. The fields +are sorted in the order in which they have been read or set except +if the order has been overridden with set_output_order(). + +=item $c->output($fh) + +Print the string representation of the control information to a +filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + my $str = ''; + my @keys; + if (@{$$self->{out_order}}) { + my $i = 1; + my $imp = {}; + $imp->{$_} = $i++ foreach @{$$self->{out_order}}; + @keys = sort { + if (defined $imp->{$a} && defined $imp->{$b}) { + $imp->{$a} <=> $imp->{$b}; + } elsif (defined($imp->{$a})) { + -1; + } elsif (defined($imp->{$b})) { + 1; + } else { + $a cmp $b; + } + } keys %$self; + } else { + @keys = @{$$self->{in_order}}; + } + + foreach my $key (@keys) { + if (exists $self->{$key}) { + my $value = $self->{$key}; + # Skip whitespace-only fields + next if $$self->{drop_empty} and $value !~ m/\S/; + # Escape data to follow control file syntax + my ($first_line, @lines) = split /\n/, $value; + + my $kv = "$key:"; + $kv .= ' ' . $first_line if length $first_line; + $kv .= "\n"; + foreach (@lines) { + s/\s+$//; + if (length == 0 or /^\.+$/) { + $kv .= " .$_\n"; + } else { + $kv .= " $_\n"; + } + } + # Print it out + if ($fh) { + print { $fh } $kv + or syserr(g_('write error on control data')); + } + $str .= $kv if defined wantarray; + } + } + return $str; +} + +=item $c->save($filename) + +Write the string representation of the control information to a file. + +=item $c->set_output_order(@fields) + +Define the order in which fields will be displayed in the output() method. + +=cut + +sub set_output_order { + my ($self, @fields) = @_; + + $$self->{out_order} = [@fields]; +} + +=item $c->apply_substvars($substvars) + +Update all fields by replacing the variables references with +the corresponding value stored in the L<Dpkg::Substvars> object. + +=cut + +sub apply_substvars { + my ($self, $substvars, %opts) = @_; + + # Add substvars to refer to other fields + $substvars->set_field_substvars($self, 'F'); + + foreach my $f (keys %$self) { + my $v = $substvars->substvars($self->{$f}, %opts); + if ($v ne $self->{$f}) { + my $sep; + + $sep = field_get_sep_type($f); + + # If we replaced stuff, ensure we're not breaking + # a dependency field by introducing empty lines, or multiple + # commas + + if ($sep & (FIELD_SEP_COMMA | FIELD_SEP_LINE)) { + # Drop empty/whitespace-only lines + $v =~ s/\n[ \t]*(\n|$)/$1/; + } + + if ($sep & FIELD_SEP_COMMA) { + $v =~ s/,[\s,]*,/,/g; + $v =~ s/^\s*,\s*//; + $v =~ s/\s*,\s*$//; + } + } + # Replace ${} with $, which is otherwise an invalid substitution, but + # this then makes it possible to use ${} as an escape sequence such + # as ${}{VARIABLE}. + $v =~ s/\$\{\}/\$/g; + + $self->{$f} = $v; + } +} + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.21.0) + +New option: "keep_duplicate" in new(). + +=head2 Version 1.01 (dpkg 1.17.2) + +New method: $c->parse_error(). + +=head2 Version 1.00 (dpkg 1.17.0) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/HashCore/Tie.pm b/scripts/Dpkg/Control/HashCore/Tie.pm new file mode 100644 index 0000000..355735d --- /dev/null +++ b/scripts/Dpkg/Control/HashCore/Tie.pm @@ -0,0 +1,156 @@ +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2009, 2012-2019, 2021 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::HashCore::Tie - ties a Dpkg::Control::Hash object + +=head1 DESCRIPTION + +This module provides a class that is used to tie a hash. +It implements hash-like functions by normalizing the name of fields received +in keys (using Dpkg::Control::Fields::field_capitalize()). +It also stores the order in which fields have been added in order to be able +to dump them in the same order. +But the order information is stored in a parent object of type +L<Dpkg::Control>. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Control::HashCore::Tie 0.01; + +use strict; +use warnings; + +use Dpkg::Control::FieldsCore; + +use Carp; +use Tie::Hash; +use parent -norequire, qw(Tie::ExtraHash); + +# $self->[0] is the real hash +# $self->[1] is a reference to the hash contained by the parent object. +# This reference bypasses the top-level scalar reference of a +# Dpkg::Control::Hash, hence ensuring that reference gets DESTROYed +# properly. + +=head1 FUNCTIONS + +=over 4 + +=item Dpkg::Control::Hash->new($parent) + +Return a reference to a tied hash implementing storage of simple +"field: value" mapping as used in many Debian-specific files. + +=cut + +sub new { + my ($class, @args) = @_; + my $hash = {}; + + tie %{$hash}, $class, @args; ## no critic (Miscellanea::ProhibitTies) + return $hash; +} + +sub TIEHASH { + my ($class, $parent) = @_; + + croak 'parent object must be Dpkg::Control::Hash' + if not $parent->isa('Dpkg::Control::HashCore') and + not $parent->isa('Dpkg::Control::Hash'); + return bless [ {}, $$parent ], $class; +} + +sub FETCH { + my ($self, $key) = @_; + + $key = lc($key); + return $self->[0]->{$key} if exists $self->[0]->{$key}; + return; +} + +sub STORE { + my ($self, $key, $value) = @_; + + $key = lc($key); + if (not exists $self->[0]->{$key}) { + push @{$self->[1]->{in_order}}, field_capitalize($key); + } + $self->[0]->{$key} = $value; +} + +sub EXISTS { + my ($self, $key) = @_; + + $key = lc($key); + return exists $self->[0]->{$key}; +} + +sub DELETE { + my ($self, $key) = @_; + my $parent = $self->[1]; + my $in_order = $parent->{in_order}; + + $key = lc($key); + if (exists $self->[0]->{$key}) { + delete $self->[0]->{$key}; + @{$in_order} = grep { lc ne $key } @{$in_order}; + return 1; + } else { + return 0; + } +} + +sub FIRSTKEY { + my $self = shift; + my $parent = $self->[1]; + + foreach my $key (@{$parent->{in_order}}) { + return $key if exists $self->[0]->{lc $key}; + } +} + +sub NEXTKEY { + my ($self, $prev) = @_; + my $parent = $self->[1]; + my $found = 0; + + foreach my $key (@{$parent->{in_order}}) { + if ($found) { + return $key if exists $self->[0]->{lc $key}; + } else { + $found = 1 if $key eq $prev; + } + } + return; +} + +=back + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Info.pm b/scripts/Dpkg/Control/Info.pm new file mode 100644 index 0000000..11eec73 --- /dev/null +++ b/scripts/Dpkg/Control/Info.pm @@ -0,0 +1,227 @@ +# Copyright © 2007-2010 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2009, 2012-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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Info - parse files like debian/control + +=head1 DESCRIPTION + +It provides a class to access data of files that follow the same +syntax as F<debian/control>. + +=cut + +package Dpkg::Control::Info 1.01; + +use strict; +use warnings; + +use Dpkg::Control; +use Dpkg::ErrorHandling; +use Dpkg::Gettext; + +use parent qw(Dpkg::Interface::Storable); + +use overload + '@{}' => sub { return [ $_[0]->{source}, @{$_[0]->{packages}} ] }; + +=head1 METHODS + +=over 4 + +=item $c = Dpkg::Control::Info->new(%opts) + +Create a new Dpkg::Control::Info object. Loads the file from the filename +option, if no option is specified filename defaults to F<debian/control>. +If a scalar is passed instead, it will be used as the filename. If filename +is "-", it parses the standard input. If filename is undef no loading will +be performed. + +=cut + +sub new { + my ($this, @args) = @_; + my $class = ref($this) || $this; + my $self = { + source => undef, + packages => [], + }; + bless $self, $class; + + my %opts; + if (scalar @args == 0) { + $opts{filename} = 'debian/control'; + } elsif (scalar @args == 1) { + $opts{filename} = $args[0]; + } else { + %opts = @args; + } + + $self->load($opts{filename}) if $opts{filename}; + + return $self; +} + +=item $c->reset() + +Resets what got read. + +=cut + +sub reset { + my $self = shift; + $self->{source} = undef; + $self->{packages} = []; +} + +=item $c->parse($fh, $description) + +Parse a control file from the given filehandle. Exits in case of errors. +$description is used to describe the filehandle, ideally it's a filename +or a description of where the data comes from. It is used in error messages. +The data in the object is reset before parsing new control files. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + $self->reset(); + my $cdata = Dpkg::Control->new(type => CTRL_TMPL_SRC); + return if not $cdata->parse($fh, $desc); + $self->{source} = $cdata; + unless (exists $cdata->{Source}) { + $cdata->parse_error($desc, g_("first stanza lacks a '%s' field"), + 'Source'); + } + while (1) { + $cdata = Dpkg::Control->new(type => CTRL_TMPL_PKG); + last if not $cdata->parse($fh, $desc); + push @{$self->{packages}}, $cdata; + unless (exists $cdata->{Package}) { + $cdata->parse_error($desc, g_("stanza lacks the '%s' field"), + 'Package'); + } + unless (exists $cdata->{Architecture}) { + $cdata->parse_error($desc, g_("stanza lacks the '%s' field"), + 'Architecture'); + } + } +} + +=item $c->load($file) + +Load the content of $file. Exits in case of errors. If file is "-", it +loads from the standard input. + +=item $c->[0] + +=item $c->get_source() + +Returns a L<Dpkg::Control> object containing the fields concerning the +source package. + +=cut + +sub get_source { + my $self = shift; + return $self->{source}; +} + +=item $c->get_pkg_by_idx($idx) + +Returns a L<Dpkg::Control> object containing the fields concerning the binary +package numbered $idx (starting at 1). + +=cut + +sub get_pkg_by_idx { + my ($self, $idx) = @_; + return $self->{packages}[--$idx]; +} + +=item $c->get_pkg_by_name($name) + +Returns a L<Dpkg::Control> object containing the fields concerning the binary +package named $name. + +=cut + +sub get_pkg_by_name { + my ($self, $name) = @_; + foreach my $pkg (@{$self->{packages}}) { + return $pkg if ($pkg->{Package} eq $name); + } + return; +} + + +=item $c->get_packages() + +Returns a list containing the L<Dpkg::Control> objects for all binary packages. + +=cut + +sub get_packages { + my $self = shift; + return @{$self->{packages}}; +} + +=item $str = $c->output([$fh]) + +Return the content info into a string. If $fh is specified print it into +the filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + my $str; + $str .= $self->{source}->output($fh); + foreach my $pkg (@{$self->{packages}}) { + print { $fh } "\n" if defined $fh; + $str .= "\n" . $pkg->output($fh); + } + return $str; +} + +=item "$c" + +Return a string representation of the content. + +=item @{$c} + +Return a list of L<Dpkg::Control> objects, the first one is corresponding to +source information and the following ones are the binary packages +information. + +=back + +=head1 CHANGES + +=head2 Version 1.01 (dpkg 1.18.0) + +New argument: The $c->new() constructor accepts an %opts argument. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Tests.pm b/scripts/Dpkg/Control/Tests.pm new file mode 100644 index 0000000..687b26c --- /dev/null +++ b/scripts/Dpkg/Control/Tests.pm @@ -0,0 +1,83 @@ +# Copyright © 2016 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Tests - parse files like debian/tests/control + +=head1 DESCRIPTION + +It provides a class to access data of files that follow the same +syntax as F<debian/tests/control>. + +=cut + +package Dpkg::Control::Tests 1.00; + +use strict; +use warnings; + +use Dpkg::Control; +use Dpkg::Control::Tests::Entry; +use Dpkg::Index; + +use parent qw(Dpkg::Index); + +=head1 METHODS + +All the methods of L<Dpkg::Index> are available. Those listed below are either +new or overridden with a different behavior. + +=over 4 + +=item $c = Dpkg::Control::Tests->new(%opts) + +Create a new Dpkg::Control::Tests object, which inherits from L<Dpkg::Index>. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + my $self = Dpkg::Index->new(type => CTRL_TESTS, %opts); + + return bless $self, $class; +} + +=item $item = $tests->new_item() + +Creates a new item. + +=cut + +sub new_item { + my $self = shift; + + return Dpkg::Control::Tests::Entry->new(); +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.18.8) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Tests/Entry.pm b/scripts/Dpkg/Control/Tests/Entry.pm new file mode 100644 index 0000000..e277ef9 --- /dev/null +++ b/scripts/Dpkg/Control/Tests/Entry.pm @@ -0,0 +1,94 @@ +# Copyright © 2016 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Tests::Entry - represents a test suite entry + +=head1 DESCRIPTION + +This class represents a test suite entry. + +=cut + +package Dpkg::Control::Tests::Entry 1.00; + +use strict; +use warnings; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control; + +use parent qw(Dpkg::Control); + +=head1 METHODS + +All the methods of L<Dpkg::Control> are available. Those listed below are +either new or overridden with a different behavior. + +=over 4 + +=item $entry = Dpkg::Control::Tests::Entry->new() + +Creates a new object. It does not represent a real control test entry +until one has been successfully parsed or built from scratch. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = Dpkg::Control->new(type => CTRL_TESTS, %opts); + bless $self, $class; + return $self; +} + +=item $entry->parse($fh, $desc) + +Parse a control test entry from a filehandle. When called multiple times, +the parsed fields are accumulated. + +Returns true if parsing was a success. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + + return if not $self->SUPER::parse($fh, $desc); + + if (not exists $self->{'Tests'} and not exists $self->{'Test-Command'}) { + $self->parse_error($desc, g_('stanza lacks either %s or %s fields'), + 'Tests', 'Test-Command'); + } + + return 1; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.18.8) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Types.pm b/scripts/Dpkg/Control/Types.pm new file mode 100644 index 0000000..4a86735 --- /dev/null +++ b/scripts/Dpkg/Control/Types.pm @@ -0,0 +1,120 @@ +# 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Types - export CTRL_* constants + +=head1 DESCRIPTION + +You should not use this module directly. Instead you more likely +want to use L<Dpkg::Control> which also re-exports the same constants. + +This module has been introduced solely to avoid a dependency loop +between L<Dpkg::Control> and L<Dpkg::Control::Fields>. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Control::Types 0.01; + +use strict; +use warnings; + +our @EXPORT = qw( + CTRL_UNKNOWN + CTRL_TMPL_SRC + CTRL_TMPL_PKG + CTRL_REPO_RELEASE + CTRL_REPO_SRC + CTRL_REPO_PKG + CTRL_DSC + CTRL_DEB + CTRL_FILE_BUILDINFO + CTRL_FILE_CHANGES + CTRL_FILE_VENDOR + CTRL_FILE_STATUS + CTRL_CHANGELOG + CTRL_COPYRIGHT_HEADER + CTRL_COPYRIGHT_FILES + CTRL_COPYRIGHT_LICENSE + CTRL_TESTS + + CTRL_INFO_SRC + CTRL_INFO_PKG + CTRL_PKG_SRC + CTRL_PKG_DEB + CTRL_INDEX_SRC + CTRL_INDEX_PKG +); + +use Exporter qw(import); + +use constant { + CTRL_UNKNOWN => 0, + # First source package control stanza in debian/control. + CTRL_TMPL_SRC => 1 << 0, + # Subsequent binary package control stanza in debian/control. + CTRL_TMPL_PKG => 1 << 1, + # Entry in repository's Sources files. + CTRL_REPO_SRC => 1 << 2, + # Entry in repository's Packages files. + CTRL_REPO_PKG => 1 << 3, + # .dsc file of source package. + CTRL_DSC => 1 << 4, + # DEBIAN/control in binary packages. + CTRL_DEB => 1 << 5, + # .changes file. + CTRL_FILE_CHANGES => 1 << 6, + # File in $Dpkg::CONFDIR/origins. + CTRL_FILE_VENDOR => 1 << 7, + # $Dpkg::ADMINDIR/status. + CTRL_FILE_STATUS => 1 << 8, + # Output of dpkg-parsechangelog. + CTRL_CHANGELOG => 1 << 9, + # Repository's (In)Release file. + CTRL_REPO_RELEASE => 1 << 10, + # Header control stanza in debian/copyright. + CTRL_COPYRIGHT_HEADER => 1 << 11, + # Files control stanza in debian/copyright. + CTRL_COPYRIGHT_FILES => 1 << 12, + # License control stanza in debian/copyright. + CTRL_COPYRIGHT_LICENSE => 1 << 13, + # Package test suite control file in debian/tests/control. + CTRL_TESTS => 1 << 14, + # .buildinfo file + CTRL_FILE_BUILDINFO => 1 << 15, +}; + +# Backwards compatibility aliases. +use constant { + CTRL_INFO_SRC => CTRL_TMPL_SRC, + CTRL_INFO_PKG => CTRL_TMPL_PKG, + CTRL_PKG_SRC => CTRL_DSC, + CTRL_PKG_DEB => CTRL_DEB, + CTRL_INDEX_SRC => CTRL_REPO_SRC, + CTRL_INDEX_PKG => CTRL_REPO_PKG, +}; + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Deps.pm b/scripts/Dpkg/Deps.pm new file mode 100644 index 0000000..9593184 --- /dev/null +++ b/scripts/Dpkg/Deps.pm @@ -0,0 +1,495 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009,2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps - parse and manipulate dependencies of Debian packages + +=head1 DESCRIPTION + +The Dpkg::Deps module provides classes implementing various types of +dependencies. + +The most important function is deps_parse(), it turns a dependency line in +a set of Dpkg::Deps::{Simple,AND,OR,Union} objects depending on the case. + +=cut + +package Dpkg::Deps 1.07; + +use strict; +use warnings; +use feature qw(current_sub); + +our @EXPORT = qw( + deps_concat + deps_parse + deps_eval_implication + deps_iterate + deps_compare +); + +use Carp; +use Exporter qw(import); + +use Dpkg::Version; +use Dpkg::Arch qw(get_host_arch get_build_arch debarch_to_debtuple); +use Dpkg::BuildProfiles qw(get_build_profiles); +use Dpkg::ErrorHandling; +use Dpkg::Gettext; +use Dpkg::Deps::Simple; +use Dpkg::Deps::Union; +use Dpkg::Deps::AND; +use Dpkg::Deps::OR; +use Dpkg::Deps::KnownFacts; + +=head1 FUNCTIONS + +All the deps_* functions are exported by default. + +=over 4 + +=item deps_eval_implication($rel_p, $v_p, $rel_q, $v_q) + +($rel_p, $v_p) and ($rel_q, $v_q) express two dependencies as (relation, +version). The relation variable can have the following values that are +exported by L<Dpkg::Version>: REL_EQ, REL_LT, REL_LE, REL_GT, REL_GT. + +This functions returns 1 if the "p" dependency implies the "q" +dependency. It returns 0 if the "p" dependency implies that "q" is +not satisfied. It returns undef when there's no implication. + +The $v_p and $v_q parameter should be L<Dpkg::Version> objects. + +=cut + +sub deps_eval_implication { + my ($rel_p, $v_p, $rel_q, $v_q) = @_; + + # If versions are not valid, we can't decide of any implication + return unless defined($v_p) and $v_p->is_valid(); + return unless defined($v_q) and $v_q->is_valid(); + + # q wants an exact version, so p must provide that exact version. p + # disproves q if q's version is outside the range enforced by p. + if ($rel_q eq REL_EQ) { + if ($rel_p eq REL_LT) { + return ($v_p <= $v_q) ? 0 : undef; + } elsif ($rel_p eq REL_LE) { + return ($v_p < $v_q) ? 0 : undef; + } elsif ($rel_p eq REL_GT) { + return ($v_p >= $v_q) ? 0 : undef; + } elsif ($rel_p eq REL_GE) { + return ($v_p > $v_q) ? 0 : undef; + } elsif ($rel_p eq REL_EQ) { + return ($v_p == $v_q); + } + } + + # A greater than clause may disprove a less than clause. An equal + # cause might as well. Otherwise, if + # p's clause is <<, <=, or =, the version must be <= q's to imply q. + if ($rel_q eq REL_LE) { + if ($rel_p eq REL_GT) { + return ($v_p >= $v_q) ? 0 : undef; + } elsif ($rel_p eq REL_GE) { + return ($v_p > $v_q) ? 0 : undef; + } elsif ($rel_p eq REL_EQ) { + return ($v_p <= $v_q) ? 1 : 0; + } else { # <<, <= + return ($v_p <= $v_q) ? 1 : undef; + } + } + + # Similar, but << is stronger than <= so p's version must be << q's + # version if the p relation is <= or =. + if ($rel_q eq REL_LT) { + if ($rel_p eq REL_GT or $rel_p eq REL_GE) { + return ($v_p >= $v_p) ? 0 : undef; + } elsif ($rel_p eq REL_LT) { + return ($v_p <= $v_q) ? 1 : undef; + } elsif ($rel_p eq REL_EQ) { + return ($v_p < $v_q) ? 1 : 0; + } else { # <<, <= + return ($v_p < $v_q) ? 1 : undef; + } + } + + # Same logic as above, only inverted. + if ($rel_q eq REL_GE) { + if ($rel_p eq REL_LT) { + return ($v_p <= $v_q) ? 0 : undef; + } elsif ($rel_p eq REL_LE) { + return ($v_p < $v_q) ? 0 : undef; + } elsif ($rel_p eq REL_EQ) { + return ($v_p >= $v_q) ? 1 : 0; + } else { # >>, >= + return ($v_p >= $v_q) ? 1 : undef; + } + } + if ($rel_q eq REL_GT) { + if ($rel_p eq REL_LT or $rel_p eq REL_LE) { + return ($v_p <= $v_q) ? 0 : undef; + } elsif ($rel_p eq REL_GT) { + return ($v_p >= $v_q) ? 1 : undef; + } elsif ($rel_p eq REL_EQ) { + return ($v_p > $v_q) ? 1 : 0; + } else { + return ($v_p > $v_q) ? 1 : undef; + } + } + + return; +} + +=item $dep = deps_concat(@dep_list) + +This function concatenates multiple dependency lines into a single line, +joining them with ", " if appropriate, and always returning a valid string. + +=cut + +sub deps_concat { + my (@dep_list) = @_; + + return join ', ', grep { defined } @dep_list; +} + +=item $dep = deps_parse($line, %options) + +This function parses the dependency line and returns an object, either a +L<Dpkg::Deps::AND> or a L<Dpkg::Deps::Union>. Various options can alter the +behavior of that function. + +=over 4 + +=item use_arch (defaults to 1) + +Take into account the architecture restriction part of the dependencies. +Set to 0 to completely ignore that information. + +=item host_arch (defaults to the current architecture) + +Define the host architecture. By default it uses +Dpkg::Arch::get_host_arch() to identify the proper architecture. + +=item build_arch (defaults to the current architecture) + +Define the build architecture. By default it uses +Dpkg::Arch::get_build_arch() to identify the proper architecture. + +=item reduce_arch (defaults to 0) + +If set to 1, ignore dependencies that do not concern the current host +architecture. This implicitly strips off the architecture restriction +list so that the resulting dependencies are directly applicable to the +current architecture. + +=item use_profiles (defaults to 1) + +Take into account the profile restriction part of the dependencies. Set +to 0 to completely ignore that information. + +=item build_profiles (defaults to no profile) + +Define the active build profiles. By default no profile is defined. + +=item reduce_profiles (defaults to 0) + +If set to 1, ignore dependencies that do not concern the current build +profile. This implicitly strips off the profile restriction formula so +that the resulting dependencies are directly applicable to the current +profiles. + +=item reduce_restrictions (defaults to 0) + +If set to 1, ignore dependencies that do not concern the current set of +restrictions. This implicitly strips off any architecture restriction list +or restriction formula so that the resulting dependencies are directly +applicable to the current restriction. +This currently implies C<reduce_arch> and C<reduce_profiles>, and overrides +them if set. + +=item union (defaults to 0) + +If set to 1, returns a L<Dpkg::Deps::Union> instead of a L<Dpkg::Deps::AND>. +Use this when parsing non-dependency fields like Conflicts. + +=item virtual (defaults to 0) + +If set to 1, allow only virtual package version relations, that is none, +or "=". +This should be set whenever working with Provides fields. + +=item build_dep (defaults to 0) + +If set to 1, allow build-dep only arch qualifiers, that is ":native". +This should be set whenever working with build-deps. + +=item tests_dep (defaults to 0) + +If set to 1, allow tests-specific package names in dependencies, that is +"@" and "@builddeps@" (since dpkg 1.18.7). This should be set whenever +working with dependency fields from F<debian/tests/control>. + +This option implicitly (and forcibly) enables C<build_dep> because test +dependencies are based on build dependencies (since dpkg 1.22.1). + +=back + +=cut + +sub deps_parse { + my ($dep_line, %options) = @_; + + # Validate arguments. + croak "invalid host_arch $options{host_arch}" + if defined $options{host_arch} and not defined debarch_to_debtuple($options{host_arch}); + croak "invalid build_arch $options{build_arch}" + if defined $options{build_arch} and not defined debarch_to_debtuple($options{build_arch}); + + $options{use_arch} //= 1; + $options{reduce_arch} //= 0; + $options{use_profiles} //= 1; + $options{reduce_profiles} //= 0; + $options{reduce_restrictions} //= 0; + $options{union} //= 0; + $options{virtual} //= 0; + $options{build_dep} //= 0; + $options{tests_dep} //= 0; + + if ($options{reduce_restrictions}) { + $options{reduce_arch} = 1; + $options{reduce_profiles} = 1; + } + if ($options{reduce_arch}) { + $options{host_arch} //= get_host_arch(); + $options{build_arch} //= get_build_arch(); + } + if ($options{reduce_profiles}) { + $options{build_profiles} //= [ get_build_profiles() ]; + } + if ($options{tests_dep}) { + $options{build_dep} = 1; + } + + # Options for Dpkg::Deps::Simple. + my %deps_options = ( + host_arch => $options{host_arch}, + build_arch => $options{build_arch}, + build_dep => $options{build_dep}, + tests_dep => $options{tests_dep}, + ); + + # Merge in a single-line + $dep_line =~ s/\s*[\r\n]\s*/ /g; + # Strip trailing/leading spaces + $dep_line =~ s/^\s+//; + $dep_line =~ s/\s+$//; + + my @dep_list; + foreach my $dep_and (split(/\s*,\s*/m, $dep_line)) { + my @or_list = (); + foreach my $dep_or (split(/\s*\|\s*/m, $dep_and)) { + my $dep_simple = Dpkg::Deps::Simple->new($dep_or, %deps_options); + if (not defined $dep_simple->{package}) { + warning(g_("can't parse dependency %s"), $dep_or); + return; + } + if ($options{virtual} && defined $dep_simple->{relation} && + $dep_simple->{relation} ne '=') { + warning(g_('virtual dependency contains invalid relation: %s'), + $dep_simple->output); + return; + } + $dep_simple->{arches} = undef if not $options{use_arch}; + if ($options{reduce_arch}) { + $dep_simple->reduce_arch($options{host_arch}); + next if not $dep_simple->arch_is_concerned($options{host_arch}); + } + $dep_simple->{restrictions} = undef if not $options{use_profiles}; + if ($options{reduce_profiles}) { + $dep_simple->reduce_profiles($options{build_profiles}); + next if not $dep_simple->profile_is_concerned($options{build_profiles}); + } + push @or_list, $dep_simple; + } + next if not @or_list; + if (scalar @or_list == 1) { + push @dep_list, $or_list[0]; + } else { + my $dep_or = Dpkg::Deps::OR->new(); + $dep_or->add($_) foreach (@or_list); + push @dep_list, $dep_or; + } + } + my $dep_and; + if ($options{union}) { + $dep_and = Dpkg::Deps::Union->new(); + } else { + $dep_and = Dpkg::Deps::AND->new(); + } + foreach my $dep (@dep_list) { + if ($options{union} and not $dep->isa('Dpkg::Deps::Simple')) { + warning(g_('an union dependency can only contain simple dependencies')); + return; + } + $dep_and->add($dep); + } + return $dep_and; +} + +=item $bool = deps_iterate($deps, $callback_func) + +This function visits all elements of the dependency object, calling the +callback function for each element. + +The callback function is expected to return true when everything is fine, +or false if something went wrong, in which case the iteration will stop. + +Return the same value as the callback function. + +=cut + +sub deps_iterate { + my ($deps, $callback_func) = @_; + + my $visitor_func = sub { + foreach my $dep (@_) { + return unless defined $dep; + + if ($dep->isa('Dpkg::Deps::Simple')) { + return unless $callback_func->($dep); + } else { + return unless __SUB__->($dep->get_deps()); + } + } + return 1; + }; + + return $visitor_func->($deps); +} + +=item deps_compare($a, $b) + +Implements a comparison operator between two dependency objects. +This function is mainly used to implement the sort() method. + +=back + +=cut + +my %relation_ordering = ( + undef => 0, + REL_GE() => 1, + REL_GT() => 2, + REL_EQ() => 3, + REL_LT() => 4, + REL_LE() => 5, +); + +sub deps_compare { + my ($aref, $bref) = @_; + + my (@as, @bs); + deps_iterate($aref, sub { push @as, @_ }); + deps_iterate($bref, sub { push @bs, @_ }); + + while (1) { + my ($a, $b) = (shift @as, shift @bs); + my $aundef = not defined $a or $a->is_empty(); + my $bundef = not defined $b or $b->is_empty(); + + return 0 if $aundef and $bundef; + return -1 if $aundef; + return 1 if $bundef; + + my $ar = $a->{relation} // 'undef'; + my $br = $b->{relation} // 'undef'; + my $av = $a->{version} // ''; + my $bv = $b->{version} // ''; + + my $res = (($a->{package} cmp $b->{package}) || + ($relation_ordering{$ar} <=> $relation_ordering{$br}) || + ($av cmp $bv)); + return $res if $res != 0; + } +} + +=head1 CLASSES - Dpkg::Deps::* + +There are several kind of dependencies. A L<Dpkg::Deps::Simple> dependency +represents a single dependency statement (it relates to one package only). +L<Dpkg::Deps::Multiple> dependencies are built on top of this class +and combine several dependencies in different manners. L<Dpkg::Deps::AND> +represents the logical "AND" between dependencies while L<Dpkg::Deps::OR> +represents the logical "OR". L<Dpkg::Deps::Multiple> objects can contain +L<Dpkg::Deps::Simple> object as well as other L<Dpkg::Deps::Multiple> objects. + +In practice, the code is only meant to handle the realistic cases which, +given Debian's dependencies structure, imply those restrictions: AND can +contain Simple or OR objects, OR can only contain Simple objects. + +L<Dpkg::Deps::KnownFacts> is a special class that is used while evaluating +dependencies and while trying to simplify them. It represents a set of +installed packages along with the virtual packages that they might +provide. + +=head1 CHANGES + +=head2 Version 1.07 (dpkg 1.20.0) + +New option: Add virtual option to deps_parse(). + +=head2 Version 1.06 (dpkg 1.18.7; module version bumped on dpkg 1.18.24) + +New option: Add tests_dep option to deps_parse(). + +=head2 Version 1.05 (dpkg 1.17.14) + +New function: deps_iterate(). + +=head2 Version 1.04 (dpkg 1.17.10) + +New options: Add use_profiles, build_profiles, reduce_profiles and +reduce_restrictions to deps_parse(). + +=head2 Version 1.03 (dpkg 1.17.0) + +New option: Add build_arch option to deps_parse(). + +=head2 Version 1.02 (dpkg 1.17.0) + +New function: deps_concat() + +=head2 Version 1.01 (dpkg 1.16.1) + +<Used to document changes to Dpkg::Deps::* modules before they were split.> + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/AND.pm b/scripts/Dpkg/Deps/AND.pm new file mode 100644 index 0000000..6d46c79 --- /dev/null +++ b/scripts/Dpkg/Deps/AND.pm @@ -0,0 +1,180 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::AND - list of AND dependencies + +=head1 DESCRIPTION + +This class represents a list of dependencies that must be met at the same +time. It inherits from L<Dpkg::Deps::Multiple>. + +=cut + +package Dpkg::Deps::AND 1.00; + +use strict; +use warnings; + +use parent qw(Dpkg::Deps::Multiple); + +=head1 METHODS + +=over 4 + +=item $dep->output([$fh]) + +The output() method uses ", " to join the list of sub-dependencies. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = join(', ', map { + $_->output() + } grep { + not $_->is_empty() + } $self->get_deps()); + + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +=item $dep->implies($other_dep) + +Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies +NOT($other_dep). Returns undef when there's no implication. $dep and +$other_dep do not need to be of the same type. + +=cut + +sub implies { + my ($self, $o) = @_; + + # If any individual member can imply $o or NOT $o, we're fine + foreach my $dep ($self->get_deps()) { + my $implication = $dep->implies($o); + return 1 if defined $implication and $implication == 1; + return 0 if defined $implication and $implication == 0; + } + + # If o is an AND, we might have an implication, if we find an + # implication within us for each predicate in o + if ($o->isa('Dpkg::Deps::AND')) { + my $subset = 1; + foreach my $odep ($o->get_deps()) { + my $found = 0; + foreach my $dep ($self->get_deps()) { + $found = 1 if $dep->implies($odep); + } + $subset = 0 if not $found; + } + return 1 if $subset; + } + return; +} + +=item $dep->get_evaluation($facts) + +Evaluates the dependency given a list of installed packages and a list of +virtual packages provided. These lists are part of the +L<Dpkg::Deps::KnownFacts> object given as parameters. + +Returns 1 when it's true, 0 when it's false, undef when some information +is lacking to conclude. + +=cut + +sub get_evaluation { + my ($self, $facts) = @_; + + # Return 1 only if all members evaluates to true + # Return 0 if at least one member evaluates to false + # Return undef otherwise + my $result = 1; + foreach my $dep ($self->get_deps()) { + my $eval = $dep->get_evaluation($facts); + if (not defined $eval) { + $result = undef; + } elsif ($eval == 0) { + $result = 0; + last; + } elsif ($eval == 1) { + # Still possible + } + } + return $result; +} + +=item $dep->simplify_deps($facts, @assumed_deps) + +Simplifies the dependency as much as possible given the list of facts (see +object L<Dpkg::Deps::KnownFacts>) and a list of other dependencies that are +known to be true. + +=cut + +sub simplify_deps { + my ($self, $facts, @knowndeps) = @_; + my @new; + +WHILELOOP: + while (@{$self->{list}}) { + my $dep = shift @{$self->{list}}; + my $eval = $dep->get_evaluation($facts); + next if defined $eval and $eval == 1; + foreach my $odep (@knowndeps, @new) { + next WHILELOOP if $odep->implies($dep); + } + # When a dependency is implied by another dependency that + # follows, then invert them + # "a | b, c, a" becomes "a, c" and not "c, a" + my $i = 0; + foreach my $odep (@{$self->{list}}) { + if (defined $odep and $odep->implies($dep)) { + splice @{$self->{list}}, $i, 1; + unshift @{$self->{list}}, $odep; + next WHILELOOP; + } + $i++; + } + push @new, $dep; + } + $self->{list} = [ @new ]; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/KnownFacts.pm b/scripts/Dpkg/Deps/KnownFacts.pm new file mode 100644 index 0000000..e0b9c78 --- /dev/null +++ b/scripts/Dpkg/Deps/KnownFacts.pm @@ -0,0 +1,216 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::KnownFacts - list of installed real and virtual packages + +=head1 DESCRIPTION + +This class represents a list of installed packages and a list of virtual +packages provided (by the set of installed packages). + +=cut + +package Dpkg::Deps::KnownFacts 2.00; + +use strict; +use warnings; + +use Dpkg::Version; + +=head1 METHODS + +=over 4 + +=item $facts = Dpkg::Deps::KnownFacts->new(); + +Creates a new object. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = { + pkg => {}, + virtualpkg => {}, + }; + + bless $self, $class; + return $self; +} + +=item $facts->add_installed_package($package, $version, $arch, $multiarch) + +Records that the given version of the package is installed. If +$version/$arch is undefined we know that the package is installed but we +don't know which version/architecture it is. $multiarch is the Multi-Arch +field of the package. If $multiarch is undef, it will be equivalent to +"Multi-Arch: no". + +Note that $multiarch is only used if $arch is provided. + +=cut + +sub add_installed_package { + my ($self, $pkg, $ver, $arch, $multiarch) = @_; + my $p = { + package => $pkg, + version => $ver, + architecture => $arch, + multiarch => $multiarch // 'no', + }; + + $self->{pkg}{"$pkg:$arch"} = $p if defined $arch; + push @{$self->{pkg}{$pkg}}, $p; +} + +=item $facts->add_provided_package($virtual, $relation, $version, $by) + +Records that the "$by" package provides the $virtual package. $relation +and $version correspond to the associated relation given in the Provides +field (if present). + +=cut + +sub add_provided_package { + my ($self, $pkg, $rel, $ver, $by) = @_; + my $v = { + package => $pkg, + relation => $rel, + version => $ver, + provider => $by, + }; + + $self->{virtualpkg}{$pkg} //= []; + push @{$self->{virtualpkg}{$pkg}}, $v; +} + +## +## The functions below are private to Dpkg::Deps::KnownFacts. +## + +sub _find_package { + my ($self, $dep, $lackinfos) = @_; + my ($pkg, $archqual) = ($dep->{package}, $dep->{archqual}); + + return if not exists $self->{pkg}{$pkg}; + + my $host_arch = $dep->{host_arch} // Dpkg::Arch::get_host_arch(); + my $build_arch = $dep->{build_arch} // Dpkg::Arch::get_build_arch(); + + foreach my $p (@{$self->{pkg}{$pkg}}) { + my $a = $p->{architecture}; + my $ma = $p->{multiarch}; + + if (not defined $a) { + $$lackinfos = 1; + next; + } + if (not defined $archqual) { + return $p if $ma eq 'foreign'; + return $p if $a eq $host_arch or $a eq 'all'; + } elsif ($archqual eq 'any') { + return $p if $ma eq 'allowed'; + } elsif ($archqual eq 'native') { + return if $ma eq 'foreign'; + return $p if $a eq $build_arch or $a eq 'all'; + } else { + return $p if $a eq $archqual; + } + } + return; +} + +sub _find_virtual_packages { + my ($self, $pkg) = @_; + + return () if not exists $self->{virtualpkg}{$pkg}; + return @{$self->{virtualpkg}{$pkg}}; +} + +=item $facts->evaluate_simple_dep() + +This method is private and should not be used except from within L<Dpkg::Deps>. + +=cut + +sub evaluate_simple_dep { + my ($self, $dep) = @_; + my ($lackinfos, $pkg) = (0, $dep->{package}); + + my $p = $self->_find_package($dep, \$lackinfos); + if ($p) { + if (defined $dep->{relation}) { + if (defined $p->{version}) { + return 1 if version_compare_relation($p->{version}, + $dep->{relation}, + $dep->{version}); + } else { + $lackinfos = 1; + } + } else { + return 1; + } + } + foreach my $virtpkg ($self->_find_virtual_packages($pkg)) { + next if defined $virtpkg->{relation} and + $virtpkg->{relation} ne REL_EQ; + + if (defined $dep->{relation}) { + next if not defined $virtpkg->{version}; + return 1 if version_compare_relation($virtpkg->{version}, + $dep->{relation}, + $dep->{version}); + } else { + return 1; + } + } + return if $lackinfos; + return 0; +} + +=back + +=head1 CHANGES + +=head2 Version 2.00 (dpkg 1.20.0) + +Remove method: $facts->check_package(). + +=head2 Version 1.01 (dpkg 1.16.1) + +New option: $facts->add_installed_package() now accepts 2 +supplementary parameters ($arch and $multiarch). + +Deprecated method: $facts->check_package() is obsolete, +it should not have been part of the public API. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/Multiple.pm b/scripts/Dpkg/Deps/Multiple.pm new file mode 100644 index 0000000..1aed3ec --- /dev/null +++ b/scripts/Dpkg/Deps/Multiple.pm @@ -0,0 +1,248 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::Multiple - base module to represent multiple dependencies + +=head1 DESCRIPTION + +The Dpkg::Deps::Multiple module provides objects implementing various types +of dependencies. It is the base class for Dpkg::Deps::{AND,OR,Union}. + +=cut + +package Dpkg::Deps::Multiple 1.02; + +use strict; +use warnings; + +use Carp; + +use Dpkg::ErrorHandling; + +use parent qw(Dpkg::Interface::Storable); + +=head1 METHODS + +=over 4 + +=item $dep = Dpkg::Deps::Multiple->new(%opts); + +Creates a new object. + +=cut + +sub new { + my ($this, @deps) = @_; + my $class = ref($this) || $this; + my $self = { list => [ @deps ] }; + + bless $self, $class; + return $self; +} + +=item $dep->reset() + +Clears any dependency information stored in $dep so that $dep->is_empty() +returns true. + +=cut + +sub reset { + my $self = shift; + + $self->{list} = []; +} + +=item $dep->add(@deps) + +Adds new dependency objects at the end of the list. + +=cut + +sub add { + my ($self, @deps) = @_; + + push @{$self->{list}}, @deps; +} + +=item $dep->get_deps() + +Returns a list of sub-dependencies. + +=cut + +sub get_deps { + my $self = shift; + + return grep { not $_->is_empty() } @{$self->{list}}; +} + +=item $dep->sort() + +Sorts alphabetically the internal list of dependencies. + +=cut + +sub sort { + my $self = shift; + + my @res = (); + @res = sort { Dpkg::Deps::deps_compare($a, $b) } @{$self->{list}}; + $self->{list} = [ @res ]; +} + +=item $dep->arch_is_concerned($arch) + +Returns true if at least one of the sub-dependencies apply to this +architecture. + +=cut + +sub arch_is_concerned { + my ($self, $host_arch) = @_; + + my $res = 0; + foreach my $dep (@{$self->{list}}) { + $res = 1 if $dep->arch_is_concerned($host_arch); + } + return $res; +} + +=item $dep->reduce_arch($arch) + +Simplifies the dependencies to contain only information relevant to the +given architecture. The non-relevant sub-dependencies are simply removed. + +This trims off the architecture restriction list of L<Dpkg::Deps::Simple> +objects. + +=cut + +sub reduce_arch { + my ($self, $host_arch) = @_; + + my @new; + foreach my $dep (@{$self->{list}}) { + $dep->reduce_arch($host_arch); + push @new, $dep if $dep->arch_is_concerned($host_arch); + } + $self->{list} = [ @new ]; +} + +=item $dep->has_arch_restriction() + +Returns the list of package names that have such a restriction. + +=cut + +sub has_arch_restriction { + my $self = shift; + + my @res; + foreach my $dep (@{$self->{list}}) { + push @res, $dep->has_arch_restriction(); + } + return @res; +} + +=item $dep->profile_is_concerned() + +Returns true if at least one of the sub-dependencies apply to this profile. + +=cut + +sub profile_is_concerned { + my ($self, $build_profiles) = @_; + + my $res = 0; + foreach my $dep (@{$self->{list}}) { + $res = 1 if $dep->profile_is_concerned($build_profiles); + } + return $res; +} + +=item $dep->reduce_profiles() + +Simplifies the dependencies to contain only information relevant to the +given profile. The non-relevant sub-dependencies are simply removed. + +This trims off the profile restriction list of L<Dpkg::Deps::Simple> objects. + +=cut + +sub reduce_profiles { + my ($self, $build_profiles) = @_; + + my @new; + foreach my $dep (@{$self->{list}}) { + $dep->reduce_profiles($build_profiles); + push @new, $dep if $dep->profile_is_concerned($build_profiles); + } + $self->{list} = [ @new ]; +} + +=item $dep->is_empty() + +Returns true if the dependency is empty and doesn't contain any useful +information. This is true when a (descendant of) L<Dpkg::Deps::Multiple> +contains an empty list of dependencies. + +=cut + +sub is_empty { + my $self = shift; + + return scalar @{$self->{list}} == 0; +} + +=item $dep->merge_union($other_dep) + +This method is not meaningful for this object, and will always croak. + +=cut + +sub merge_union { + croak 'method merge_union() is only valid for Dpkg::Deps::Simple'; +} + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.17.10) + +New methods: Add $dep->profile_is_concerned() and $dep->reduce_profiles(). + +=head2 Version 1.01 (dpkg 1.16.1) + +New method: Add $dep->reset(). + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/OR.pm b/scripts/Dpkg/Deps/OR.pm new file mode 100644 index 0000000..b2727ba --- /dev/null +++ b/scripts/Dpkg/Deps/OR.pm @@ -0,0 +1,172 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::OR - list of OR dependencies + +=head1 DESCRIPTION + +This class represents a list of dependencies of which only one must be met +for the dependency to be true. It inherits from L<Dpkg::Deps::Multiple>. + +=cut + +package Dpkg::Deps::OR 1.00; + +use strict; +use warnings; + +use parent qw(Dpkg::Deps::Multiple); + +=head1 METHODS + +=over 4 + +=item $dep->output([$fh]) + +The output() method uses " | " to join the list of sub-dependencies. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = join(' | ', map { + $_->output() + } grep { + not $_->is_empty() + } $self->get_deps()); + + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +=item $dep->implies($other_dep) + +Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies +NOT($other_dep). Returns undef when there's no implication. $dep and +$other_dep do not need to be of the same type. + +=cut + +sub implies { + my ($self, $o) = @_; + + # Special case for AND with a single member, replace it by its member + if ($o->isa('Dpkg::Deps::AND')) { + my @subdeps = $o->get_deps(); + if (scalar(@subdeps) == 1) { + $o = $subdeps[0]; + } + } + + # In general, an OR dependency can't imply anything except if each + # of its member implies a member in the other OR dependency + if ($o->isa('Dpkg::Deps::OR')) { + my $subset = 1; + foreach my $dep ($self->get_deps()) { + my $found = 0; + foreach my $odep ($o->get_deps()) { + $found = 1 if $dep->implies($odep); + } + $subset = 0 if not $found; + } + return 1 if $subset; + } + return; +} + +=item $dep->get_evaluation($facts) + +Evaluates the dependency given a list of installed packages and a list of +virtual packages provided. These lists are part of the +L<Dpkg::Deps::KnownFacts> object given as parameters. + +Returns 1 when it's true, 0 when it's false, undef when some information +is lacking to conclude. + +=cut + +sub get_evaluation { + my ($self, $facts) = @_; + + # Returns false if all members evaluates to 0 + # Returns true if at least one member evaluates to true + # Returns undef otherwise + my $result = 0; + foreach my $dep ($self->get_deps()) { + my $eval = $dep->get_evaluation($facts); + if (not defined $eval) { + $result = undef; + } elsif ($eval == 1) { + $result = 1; + last; + } elsif ($eval == 0) { + # Still possible to have a false evaluation + } + } + return $result; +} + +=item $dep->simplify_deps($facts, @assumed_deps) + +Simplifies the dependency as much as possible given the list of facts (see +object L<Dpkg::Deps::KnownFacts>) and a list of other dependencies that are +known to be true. + +=cut + +sub simplify_deps { + my ($self, $facts) = @_; + my @new; + +WHILELOOP: + while (@{$self->{list}}) { + my $dep = shift @{$self->{list}}; + my $eval = $dep->get_evaluation($facts); + if (defined $eval and $eval == 1) { + $self->{list} = []; + return; + } + foreach my $odep (@new, @{$self->{list}}) { + next WHILELOOP if $odep->implies($dep); + } + push @new, $dep; + } + $self->{list} = [ @new ]; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/Simple.pm b/scripts/Dpkg/Deps/Simple.pm new file mode 100644 index 0000000..a2ab2b1 --- /dev/null +++ b/scripts/Dpkg/Deps/Simple.pm @@ -0,0 +1,674 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::Simple - represents a single dependency statement + +=head1 DESCRIPTION + +This class represents a single dependency statement. +It has several interesting properties: + +=over 4 + +=item package + +The package name (can be undef if the dependency has not been initialized +or if the simplification of the dependency lead to its removal). + +=item relation + +The relational operator: "=", "<<", "<=", ">=" or ">>". It can be +undefined if the dependency had no version restriction. In that case the +following field is also undefined. + +=item version + +The version. + +=item arches + +The list of architectures where this dependency is applicable. It is +undefined when there's no restriction, otherwise it is an +array ref. It can contain an exclusion list, in that case each +architecture is prefixed with an exclamation mark. + +=item archqual + +The arch qualifier of the dependency (can be undef if there is none). +In the dependency "python:any (>= 2.6)", the arch qualifier is "any". + +=item restrictions + +The restrictions formula for this dependency. It is undefined when there +is no restriction formula. Otherwise it is an array ref. + +=back + +=cut + +package Dpkg::Deps::Simple 1.02; + +use strict; +use warnings; + +use Carp; + +use Dpkg::Arch qw(debarch_is_concerned debarch_list_parse); +use Dpkg::BuildProfiles qw(parse_build_profiles evaluate_restriction_formula); +use Dpkg::Version; +use Dpkg::ErrorHandling; +use Dpkg::Gettext; + +use parent qw(Dpkg::Interface::Storable); + +=head1 METHODS + +=over 4 + +=item $dep = Dpkg::Deps::Simple->new([$dep[, %opts]]); + +Creates a new object. Some options can be set through %opts: + +=over + +=item host_arch + +Sets the host architecture. + +=item build_arch + +Sets the build architecture. + +=item build_dep + +Specifies whether the parser should consider it a build dependency. +Defaults to 0. + +=item tests_dep + +Specifies whether the parser should consider it a tests dependency. +Defaults to 0. + +This option implicitly (and forcibly) enables C<build_dep> because test +dependencies are based on build dependencies (since dpkg 1.22.1). + +=back + +=cut + +sub new { + my ($this, $arg, %opts) = @_; + my $class = ref($this) || $this; + my $self = {}; + + bless $self, $class; + $self->reset(); + $self->{host_arch} = $opts{host_arch}; + $self->{build_arch} = $opts{build_arch}; + $self->{build_dep} = $opts{build_dep} // 0; + $self->{tests_dep} = $opts{tests_dep} // 0; + if ($self->{tests_dep}) { + $self->{build_dep} = 1; + } + + $self->parse_string($arg) if defined $arg; + return $self; +} + +=item $dep->reset() + +Clears any dependency information stored in $dep so that $dep->is_empty() +returns true. + +=cut + +sub reset { + my $self = shift; + + $self->{package} = undef; + $self->{relation} = undef; + $self->{version} = undef; + $self->{arches} = undef; + $self->{archqual} = undef; + $self->{restrictions} = undef; +} + +=item $dep->parse_string($dep_string) + +Parses the dependency string and modifies internal properties to match the +parsed dependency. + +=cut + +sub parse_string { + my ($self, $dep) = @_; + + my $pkgname_re; + if ($self->{tests_dep}) { + $pkgname_re = qr/[\@a-zA-Z0-9][\@a-zA-Z0-9+.-]*/; + } else { + $pkgname_re = qr/[a-zA-Z0-9][a-zA-Z0-9+.-]*/; + } + + ## no critic (RegularExpressions::ProhibitCaptureWithoutTest) + return if not $dep =~ + m{^\s* # skip leading whitespace + ($pkgname_re) # package name + (?: # start of optional part + : # colon for architecture + ([a-zA-Z0-9][a-zA-Z0-9-]*) # architecture name + )? # end of optional part + (?: # start of optional part + \s* \( # open parenthesis for version part + \s* (<<|<=|=|>=|>>|[<>]) # relation part + \s* ([^\)\s]+) # do not attempt to parse version + \s* \) # closing parenthesis + )? # end of optional part + (?: # start of optional architecture + \s* \[ # open bracket for architecture + \s* ([^\]]+) # don't parse architectures now + \s* \] # closing bracket + )? # end of optional architecture + ( + (?: # start of optional restriction + \s* < # open bracket for restriction + \s* [^>]+ # do not parse restrictions now + \s* > # closing bracket + )+ + )? # end of optional restriction + \s*$ # trailing spaces at end + }x; + if (defined $2) { + return if $2 eq 'native' and not $self->{build_dep}; + $self->{archqual} = $2; + } + $self->{package} = $1; + $self->{relation} = version_normalize_relation($3) if defined $3; + if (defined $4) { + $self->{version} = Dpkg::Version->new($4); + } + if (defined $5) { + $self->{arches} = [ debarch_list_parse($5) ]; + } + if (defined $6) { + $self->{restrictions} = [ parse_build_profiles($6) ]; + } +} + +=item $dep->parse($fh, $desc) + +Parse a dependency line from a filehandle. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + + my $line = <$fh>; + chomp $line; + return $self->parse_string($line); +} + +=item $dep->load($filename) + +Parse a dependency line from $filename. + +=item $dep->output([$fh]) + +=item "$dep" + +Returns a string representing the dependency. If $fh is set, it prints +the string to the filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = $self->{package}; + if (defined $self->{archqual}) { + $res .= ':' . $self->{archqual}; + } + if (defined $self->{relation}) { + $res .= ' (' . $self->{relation} . ' ' . $self->{version} . ')'; + } + if (defined $self->{arches}) { + $res .= ' [' . join(' ', @{$self->{arches}}) . ']'; + } + if (defined $self->{restrictions}) { + for my $restrlist (@{$self->{restrictions}}) { + $res .= ' <' . join(' ', @{$restrlist}) . '>'; + } + } + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +=item $dep->save($filename) + +Save the dependency into the given $filename. + +=cut + +# _arch_is_superset(\@p, \@q) +# +# Returns true if the arch list @p is a superset of arch list @q. +# The arguments can also be undef in case there's no explicit architecture +# restriction. +sub _arch_is_superset { + my ($p, $q) = @_; + my $p_arch_neg = defined $p and $p->[0] =~ /^!/; + my $q_arch_neg = defined $q and $q->[0] =~ /^!/; + + if (not defined $p) { + # If "p" has no arches, it is a superset of q and we should fall through + # to the version check. + return 1; + } elsif (not defined $q) { + # If q has no arches, it is a superset of p and there are no useful + # implications. + return 0; + } elsif (not $p_arch_neg and not $q_arch_neg) { + # Both have arches. If neither are negated, we know nothing useful + # unless q is a subset of p. + + my %p_arches = map { $_ => 1 } @{$p}; + my $subset = 1; + for my $arch (@{$q}) { + $subset = 0 unless $p_arches{$arch}; + } + return 0 unless $subset; + } elsif ($p_arch_neg and $q_arch_neg) { + # If both are negated, we know nothing useful unless p is a subset of + # q (and therefore has fewer things excluded, and therefore is more + # general). + + my %q_arches = map { $_ => 1 } @{$q}; + my $subset = 1; + for my $arch (@{$p}) { + $subset = 0 unless $q_arches{$arch}; + } + return 0 unless $subset; + } elsif (not $p_arch_neg and $q_arch_neg) { + # If q is negated and p isn't, we'd need to know the full list of + # arches to know if there's any relationship, so bail. + return 0; + } elsif ($p_arch_neg and not $q_arch_neg) { + # If p is negated and q isn't, q is a subset of p if none of the + # negated arches in p are present in q. + + my %q_arches = map { $_ => 1 } @{$q}; + my $subset = 1; + for my $arch (@{$p}) { + $subset = 0 if $q_arches{substr($arch, 1)}; + } + return 0 unless $subset; + } + return 1; +} + +# _arch_qualifier_implies($p, $q) +# +# Returns true if the arch qualifier $p and $q are compatible with the +# implication $p -> $q, false otherwise. $p/$q can be undef/"any"/"native" +# or an architecture string. +# +# Because we are handling dependencies in isolation, and the full context +# of the implications are only known when doing dependency resolution at +# run-time, we can only assert that they are implied if they are equal. +# +# For example dependencies with different arch-qualifiers cannot be simplified +# as these depend on the state of Multi-Arch field in the package depended on. +sub _arch_qualifier_implies { + my ($p, $q) = @_; + + return $p eq $q if defined $p and defined $q; + return 1 if not defined $p and not defined $q; + return 0; +} + +# _restrictions_imply($p, $q) +# +# Returns true if the restrictions $p and $q are compatible with the +# implication $p -> $q, false otherwise. +# NOTE: We don't try to be very clever here, so we may conservatively +# return false when there is an implication. +sub _restrictions_imply { + my ($p, $q) = @_; + + if (not defined $p) { + return 1; + } elsif (not defined $q) { + return 0; + } else { + # Check whether set difference is empty. + my %restr; + + for my $restrlist (@{$q}) { + my $reststr = join ' ', sort @{$restrlist}; + $restr{$reststr} = 1; + } + for my $restrlist (@{$p}) { + my $reststr = join ' ', sort @{$restrlist}; + delete $restr{$reststr}; + } + + return keys %restr == 0; + } +} + +=item $dep->implies($other_dep) + +Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies +NOT($other_dep). Returns undef when there is no implication. $dep and +$other_dep do not need to be of the same type. + +=cut + +sub implies { + my ($self, $o) = @_; + + if ($o->isa('Dpkg::Deps::Simple')) { + # An implication is only possible on the same package + return if $self->{package} ne $o->{package}; + + # Our architecture set must be a superset of the architectures for + # o, otherwise we can't conclude anything. + return unless _arch_is_superset($self->{arches}, $o->{arches}); + + # The arch qualifier must not forbid an implication + return unless _arch_qualifier_implies($self->{archqual}, + $o->{archqual}); + + # Our restrictions must imply the restrictions for o + return unless _restrictions_imply($self->{restrictions}, + $o->{restrictions}); + + # If o has no version clause, then our dependency is stronger + return 1 if not defined $o->{relation}; + # If o has a version clause, we must also have one, otherwise there + # can't be an implication + return if not defined $self->{relation}; + + return Dpkg::Deps::deps_eval_implication($self->{relation}, + $self->{version}, $o->{relation}, $o->{version}); + } elsif ($o->isa('Dpkg::Deps::AND')) { + # TRUE: Need to imply all individual elements + # FALSE: Need to NOT imply at least one individual element + my $res = 1; + foreach my $dep ($o->get_deps()) { + my $implication = $self->implies($dep); + unless (defined $implication and $implication == 1) { + $res = $implication; + last if defined $res; + } + } + return $res; + } elsif ($o->isa('Dpkg::Deps::OR')) { + # TRUE: Need to imply at least one individual element + # FALSE: Need to not apply all individual elements + # UNDEF: The rest + my $res = undef; + foreach my $dep ($o->get_deps()) { + my $implication = $self->implies($dep); + if (defined $implication) { + if (not defined $res) { + $res = $implication; + } else { + if ($implication) { + $res = 1; + } else { + $res = 0; + } + } + last if defined $res and $res == 1; + } + } + return $res; + } else { + croak 'Dpkg::Deps::Simple cannot evaluate implication with a ' . + ref($o); + } +} + +=item $dep->get_deps() + +Returns a list of sub-dependencies, which for this object it means it +returns itself. + +=cut + +sub get_deps { + my $self = shift; + + return $self; +} + +=item $dep->sort() + +This method is a no-op for this object. + +=cut + +sub sort { + # Nothing to sort +} + +=item $dep->arch_is_concerned($arch) + +Returns true if the dependency applies to the indicated architecture. + +=cut + +sub arch_is_concerned { + my ($self, $host_arch) = @_; + + return 0 if not defined $self->{package}; # Empty dep + return 1 if not defined $self->{arches}; # Dep without arch spec + + return debarch_is_concerned($host_arch, @{$self->{arches}}); +} + +=item $dep->reduce_arch($arch) + +Simplifies the dependency to contain only information relevant to the given +architecture. This object can be left empty after this operation. This trims +off the architecture restriction list of these objects. + +=cut + +sub reduce_arch { + my ($self, $host_arch) = @_; + + if (not $self->arch_is_concerned($host_arch)) { + $self->reset(); + } else { + $self->{arches} = undef; + } +} + +=item $dep->has_arch_restriction() + +Returns the package name if the dependency applies only to a subset of +architectures. + +=cut + +sub has_arch_restriction { + my $self = shift; + + if (defined $self->{arches}) { + return $self->{package}; + } else { + return (); + } +} + +=item $dep->profile_is_concerned() + +Returns true if the dependency applies to the indicated profile. + +=cut + +sub profile_is_concerned { + my ($self, $build_profiles) = @_; + + return 0 if not defined $self->{package}; # Empty dep + return 1 if not defined $self->{restrictions}; # Dep without restrictions + return evaluate_restriction_formula($self->{restrictions}, $build_profiles); +} + +=item $dep->reduce_profiles() + +Simplifies the dependency to contain only information relevant to the given +profile. This object can be left empty after this operation. This trims off +the profile restriction list of this object. + +=cut + +sub reduce_profiles { + my ($self, $build_profiles) = @_; + + if (not $self->profile_is_concerned($build_profiles)) { + $self->reset(); + } else { + $self->{restrictions} = undef; + } +} + +=item $dep->get_evaluation($facts) + +Evaluates the dependency given a list of installed packages and a list of +virtual packages provided. These lists are part of the +L<Dpkg::Deps::KnownFacts> object given as parameters. + +Returns 1 when it's true, 0 when it's false, undef when some information +is lacking to conclude. + +=cut + +sub get_evaluation { + my ($self, $facts) = @_; + + return if not defined $self->{package}; + return $facts->evaluate_simple_dep($self); +} + +=item $dep->simplify_deps($facts, @assumed_deps) + +Simplifies the dependency as much as possible given the list of facts (see +class L<Dpkg::Deps::KnownFacts>) and a list of other dependencies that are +known to be true. + +=cut + +sub simplify_deps { + my ($self, $facts) = @_; + + my $eval = $self->get_evaluation($facts); + $self->reset() if defined $eval and $eval == 1; +} + +=item $dep->is_empty() + +Returns true if the dependency is empty and doesn't contain any useful +information. This is true when the object has not yet been initialized. + +=cut + +sub is_empty { + my $self = shift; + + return not defined $self->{package}; +} + +=item $dep->merge_union($other_dep) + +Returns true if $dep could be modified to represent the union of both +dependencies. Otherwise returns false. + +=cut + +sub merge_union { + my ($self, $o) = @_; + + return 0 if not $o->isa('Dpkg::Deps::Simple'); + return 0 if $self->is_empty() or $o->is_empty(); + return 0 if $self->{package} ne $o->{package}; + return 0 if defined $self->{arches} or defined $o->{arches}; + + if (not defined $o->{relation} and defined $self->{relation}) { + # Union is the non-versioned dependency + $self->{relation} = undef; + $self->{version} = undef; + return 1; + } + + my $implication = $self->implies($o); + my $rev_implication = $o->implies($self); + if (defined $implication) { + if ($implication) { + $self->{relation} = $o->{relation}; + $self->{version} = $o->{version}; + return 1; + } else { + return 0; + } + } + if (defined $rev_implication) { + if ($rev_implication) { + # Already merged... + return 1; + } else { + return 0; + } + } + return 0; +} + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.17.10) + +New methods: Add $dep->profile_is_concerned() and $dep->reduce_profiles(). + +=head2 Version 1.01 (dpkg 1.16.1) + +New method: Add $dep->reset(). + +New property: recognizes the arch qualifier "any" and stores it in the +"archqual" property when present. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/Union.pm b/scripts/Dpkg/Deps/Union.pm new file mode 100644 index 0000000..3da8ce0 --- /dev/null +++ b/scripts/Dpkg/Deps/Union.pm @@ -0,0 +1,117 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::Union - list of unrelated dependencies + +=head1 DESCRIPTION + +This class represents a list of relationships. +It inherits from L<Dpkg::Deps::Multiple>. + +=cut + +package Dpkg::Deps::Union 1.00; + +use strict; +use warnings; + +use parent qw(Dpkg::Deps::Multiple); + +=head1 METHODS + +=over 4 + +=item $dep->output([$fh]) + +The output() method uses ", " to join the list of relationships. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = join(', ', map { + $_->output() + } grep { + not $_->is_empty() + } $self->get_deps()); + + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +=item $dep->implies($other_dep) + +=item $dep->get_evaluation($other_dep) + +These methods are not meaningful for this object and always return undef. + +=cut + +sub implies { + # Implication test is not useful on Union. + return; +} + +sub get_evaluation { + # Evaluation is not useful on Union. + return; +} + +=item $dep->simplify_deps($facts) + +The simplification is done to generate an union of all the relationships. +It uses $simple_dep->merge_union($other_dep) to get its job done. + +=cut + +sub simplify_deps { + my ($self, $facts) = @_; + my @new; + +WHILELOOP: + while (@{$self->{list}}) { + my $odep = shift @{$self->{list}}; + foreach my $dep (@new) { + next WHILELOOP if $dep->merge_union($odep); + } + push @new, $odep; + } + $self->{list} = [ @new ]; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Dist/Files.pm b/scripts/Dpkg/Dist/Files.pm new file mode 100644 index 0000000..1a9fa1f --- /dev/null +++ b/scripts/Dpkg/Dist/Files.pm @@ -0,0 +1,219 @@ +# Copyright © 2014-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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Dist::Files - handle built artifacts to distribute + +=head1 DESCRIPTION + +This module provides a class used to parse and write the F<debian/files> +file, as part of the list of built artifacts to include in an upload. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Dist::Files 0.01; + +use strict; +use warnings; + +use IO::Dir; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +use parent qw(Dpkg::Interface::Storable); + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = { + options => [], + files => {}, + }; + foreach my $opt (keys %opts) { + $self->{$opt} = $opts{$opt}; + } + bless $self, $class; + + return $self; +} + +sub reset { + my $self = shift; + + $self->{files} = {}; +} + +sub parse_filename { + my ($self, $fn) = @_; + + my $file; + + if ($fn =~ m/^(([-+:.0-9a-z]+)_([^_]+)_([-\w]+)\.([a-z0-9.]+))$/) { + # Artifact using the common <name>_<version>_<arch>.<type> pattern. + $file->{filename} = $1; + $file->{package} = $2; + $file->{version} = $3; + $file->{arch} = $4; + $file->{package_type} = $5; + } elsif ($fn =~ m/^([-+:.,_0-9a-zA-Z~]+)$/) { + # Artifact with no common pattern, usually called byhand or raw, as + # they might require manual processing on the server side, or custom + # actions per file type. + $file->{filename} = $1; + } else { + $file = undef; + } + + return $file; +} + +sub parse { + my ($self, $fh, $desc) = @_; + my $count = 0; + + local $_; + binmode $fh; + + while (<$fh>) { + chomp; + + my $file; + + if (m/^(\S+) (\S+) (\S+)((?:\s+[0-9a-z-]+=\S+)*)$/) { + $file = $self->parse_filename($1); + error(g_('badly formed file name in files list file, line %d'), $.) + unless defined $file; + $file->{section} = $2; + $file->{priority} = $3; + my $attrs = $4; + $file->{attrs} = { map { split /=/ } split ' ', $attrs }; + } else { + error(g_('badly formed line in files list file, line %d'), $.); + } + + if (defined $self->{files}->{$file->{filename}}) { + warning(g_('duplicate files list entry for file %s (line %d)'), + $file->{filename}, $.); + } else { + $count++; + $self->{files}->{$file->{filename}} = $file; + } + } + + return $count; +} + +sub load_dir { + my ($self, $dir) = @_; + + my $count = 0; + my $dh = IO::Dir->new($dir) or syserr(g_('cannot open directory %s'), $dir); + + while (defined(my $file = $dh->read)) { + my $pathname = "$dir/$file"; + next unless -f $pathname; + $count += $self->load($pathname); + } + + return $count; +} + +sub get_files { + my $self = shift; + + return map { $self->{files}->{$_} } sort keys %{$self->{files}}; +} + +sub get_file { + my ($self, $filename) = @_; + + return $self->{files}->{$filename}; +} + +sub add_file { + my ($self, $filename, $section, $priority, %attrs) = @_; + + my $file = $self->parse_filename($filename); + error(g_('invalid filename %s'), $filename) unless defined $file; + $file->{section} = $section; + $file->{priority} = $priority; + $file->{attrs} = \%attrs; + + $self->{files}->{$filename} = $file; + + return $file; +} + +sub del_file { + my ($self, $filename) = @_; + + delete $self->{files}->{$filename}; +} + +sub filter { + my ($self, %opts) = @_; + my $remove = $opts{remove} // sub { 0 }; + my $keep = $opts{keep} // sub { 1 }; + + foreach my $filename (keys %{$self->{files}}) { + my $file = $self->{files}->{$filename}; + + if (not $keep->($file) or $remove->($file)) { + delete $self->{files}->{$filename}; + } + } +} + +sub output { + my ($self, $fh) = @_; + my $str = ''; + + binmode $fh if defined $fh; + + foreach my $filename (sort keys %{$self->{files}}) { + my $file = $self->{files}->{$filename}; + my $entry = "$filename $file->{section} $file->{priority}"; + + if (exists $file->{attrs}) { + foreach my $attr (sort keys %{$file->{attrs}}) { + $entry .= " $attr=$file->{attrs}->{$attr}"; + } + } + + $entry .= "\n"; + + print { $fh } $entry if defined $fh; + $str .= $entry; + } + + return $str; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/ErrorHandling.pm b/scripts/Dpkg/ErrorHandling.pm new file mode 100644 index 0000000..253298b --- /dev/null +++ b/scripts/Dpkg/ErrorHandling.pm @@ -0,0 +1,296 @@ +# 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::ErrorHandling - handle error conditions + +=head1 DESCRIPTION + +This module provides functions to handle all reporting and error handling. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::ErrorHandling 0.02; + +use strict; +use warnings; +use feature qw(state); + +our @EXPORT_OK = qw( + REPORT_PROGNAME + REPORT_COMMAND + REPORT_STATUS + REPORT_DEBUG + REPORT_INFO + REPORT_NOTICE + REPORT_WARN + REPORT_ERROR + report_pretty + report_color + report +); +our @EXPORT = qw( + report_options + debug + info + notice + warning + error + errormsg + syserr + printcmd + subprocerr + usageerr +); + +use Exporter qw(import); + +use Dpkg (); +use Dpkg::Gettext; + +my $quiet_warnings = 0; +my $debug_level = 0; +my $info_fh = \*STDOUT; + +sub setup_color +{ + my $mode = $ENV{'DPKG_COLORS'} // 'auto'; + my $use_color; + + if ($mode eq 'auto') { + ## no critic (InputOutput::ProhibitInteractiveTest) + $use_color = 1 if -t *STDOUT or -t *STDERR; + } elsif ($mode eq 'always') { + $use_color = 1; + } else { + $use_color = 0; + } + + require Term::ANSIColor if $use_color; +} + +use constant { + REPORT_PROGNAME => 1, + REPORT_COMMAND => 2, + REPORT_STATUS => 3, + REPORT_INFO => 4, + REPORT_NOTICE => 5, + REPORT_WARN => 6, + REPORT_ERROR => 7, + REPORT_DEBUG => 8, +}; + +my %report_mode = ( + REPORT_PROGNAME() => { + color => 'bold', + }, + REPORT_COMMAND() => { + color => 'bold magenta', + }, + REPORT_STATUS() => { + color => 'clear', + # We do not translate this name because the untranslated output is + # part of the interface. + name => 'status', + }, + REPORT_DEBUG() => { + color => 'clear', + # We do not translate this name because it is a developer interface + # and all debug messages are untranslated anyway. + name => 'debug', + }, + REPORT_INFO() => { + color => 'green', + name => g_('info'), + }, + REPORT_NOTICE() => { + color => 'yellow', + name => g_('notice'), + }, + REPORT_WARN() => { + color => 'bold yellow', + name => g_('warning'), + }, + REPORT_ERROR() => { + color => 'bold red', + name => g_('error'), + }, +); + +sub report_options +{ + my (%options) = @_; + + if (exists $options{quiet_warnings}) { + $quiet_warnings = $options{quiet_warnings}; + } + if (exists $options{debug_level}) { + $debug_level = $options{debug_level}; + } + if (exists $options{info_fh}) { + $info_fh = $options{info_fh}; + } +} + +sub report_name +{ + my $type = shift; + + return $report_mode{$type}{name} // ''; +} + +sub report_color +{ + my $type = shift; + + return $report_mode{$type}{color} // 'clear'; +} + +sub report_pretty +{ + my ($msg, $color) = @_; + + state $use_color = setup_color(); + + if ($use_color) { + return Term::ANSIColor::colored($msg, $color); + } else { + return $msg; + } +} + +sub _progname_prefix +{ + return report_pretty("$Dpkg::PROGNAME: ", report_color(REPORT_PROGNAME)); +} + +sub _typename_prefix +{ + my $type = shift; + + return report_pretty(report_name($type), report_color($type)); +} + +sub report(@) +{ + my ($type, $msg, @args) = @_; + + $msg = sprintf $msg, @args if @args; + + my $progname = _progname_prefix(); + my $typename = _typename_prefix($type); + + return "$progname$typename: $msg\n"; +} + +sub debug +{ + my ($level, @args) = @_; + + print report(REPORT_DEBUG, @args) if $level <= $debug_level; +} + +sub info($;@) +{ + my @args = @_; + + print { $info_fh } report(REPORT_INFO, @args) if not $quiet_warnings; +} + +sub notice +{ + my @args = @_; + + warn report(REPORT_NOTICE, @args) if not $quiet_warnings; +} + +sub warning($;@) +{ + my @args = @_; + + warn report(REPORT_WARN, @args) if not $quiet_warnings; +} + +sub syserr($;@) +{ + my ($msg, @args) = @_; + + die report(REPORT_ERROR, "$msg: $!", @args); +} + +sub error($;@) +{ + my @args = @_; + + die report(REPORT_ERROR, @args); +} + +sub errormsg($;@) +{ + my @args = @_; + + print { *STDERR } report(REPORT_ERROR, @args); +} + +sub printcmd +{ + my (@cmd) = @_; + + print { *STDERR } report_pretty(" @cmd\n", report_color(REPORT_COMMAND)); +} + +sub subprocerr(@) +{ + my ($p, @args) = @_; + + $p = sprintf $p, @args if @args; + + require POSIX; + + if (POSIX::WIFEXITED($?)) { + my $ret = POSIX::WEXITSTATUS($?); + error(g_('%s subprocess returned exit status %d'), $p, $ret); + } elsif (POSIX::WIFSIGNALED($?)) { + my $sig = POSIX::WTERMSIG($?); + error(g_('%s subprocess was killed by signal %d'), $p, $sig); + } else { + error(g_('%s subprocess failed with unknown status code %d'), $p, $?); + } +} + +sub usageerr(@) +{ + my ($msg, @args) = @_; + + state $printforhelp = g_('Use --help for program usage information.'); + + $msg = sprintf $msg, @args if @args; + warn report(REPORT_ERROR, $msg); + warn "\n$printforhelp\n"; + exit(2); +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Exit.pm b/scripts/Dpkg/Exit.pm new file mode 100644 index 0000000..fe781fc --- /dev/null +++ b/scripts/Dpkg/Exit.pm @@ -0,0 +1,133 @@ +# Copyright © 2002 Adam Heath <doogie@debian.org> +# Copyright © 2012-2013 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Exit - program exit handlers + +=head1 DESCRIPTION + +The Dpkg::Exit module provides support functions to run handlers on exit. + +=cut + +package Dpkg::Exit 2.00; + +use strict; +use warnings; + +our @EXPORT_OK = qw( + push_exit_handler + pop_exit_handler + run_exit_handlers +); + +use Exporter qw(import); + +my @handlers = (); + +=head1 FUNCTIONS + +=over 4 + +=item push_exit_handler($func) + +Register a code reference into the exit function handlers stack. + +=cut + +sub push_exit_handler { + my ($func) = shift; + + _setup_exit_handlers() if @handlers == 0; + push @handlers, $func; +} + +=item pop_exit_handler() + +Pop the last registered exit handler from the handlers stack. + +=cut + +sub pop_exit_handler { + _reset_exit_handlers() if @handlers == 1; + pop @handlers; +} + +=item run_exit_handlers() + +Run the registered exit handlers. + +=cut + +sub run_exit_handlers { + while (my $handler = pop @handlers) { + $handler->(); + } + _reset_exit_handlers(); +} + +sub _exit_handler { + run_exit_handlers(); + exit(127); +} + +my @SIGNAMES = qw(INT HUP QUIT); +my %SIGOLD; + +sub _setup_exit_handlers +{ + foreach my $signame (@SIGNAMES) { + $SIGOLD{$signame} = $SIG{$signame}; + $SIG{$signame} = \&_exit_handler; + } +} + +sub _reset_exit_handlers +{ + foreach my $signame (@SIGNAMES) { + $SIG{$signame} = $SIGOLD{$signame}; + } +} + +END { + local $?; + run_exit_handlers(); +} + +=back + +=head1 CHANGES + +=head2 Version 2.00 (dpkg 1.20.0) + +Hide variable: @handlers. + +=head2 Version 1.01 (dpkg 1.17.2) + +New functions: push_exit_handler(), pop_exit_handler(), run_exit_handlers() + +Deprecated variable: @handlers + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/File.pm b/scripts/Dpkg/File.pm new file mode 100644 index 0000000..2084e6b --- /dev/null +++ b/scripts/Dpkg/File.pm @@ -0,0 +1,100 @@ +# Copyright © 2011 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2012 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::File - file handling + +=head1 DESCRIPTION + +This module provides file handling support functions. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::File 0.01; + +use strict; +use warnings; + +our @EXPORT = qw( + file_slurp + file_dump + file_touch +); + +use Exporter qw(import); +use Scalar::Util qw(openhandle); + +use Dpkg::ErrorHandling; +use Dpkg::Gettext; + +sub file_slurp { + my $file = shift; + my $fh; + my $doclose = 0; + + if (openhandle($file)) { + $fh = $file; + } else { + open $fh, '<', $file or syserr(g_('cannot read %s'), $fh); + $doclose = 1; + } + local $/; + my $data = <$fh>; + close $fh if $doclose; + + return $data; +} + +sub file_dump { + my ($file, $data) = @_; + my $fh; + my $doclose = 0; + + if (openhandle($file)) { + $fh = $file; + } else { + open $fh, '>', $file or syserr(g_('cannot create file %s'), $file); + $doclose = 1; + } + print { $fh } $data; + if ($doclose) { + close $fh or syserr(g_('cannot write %s'), $file); + } + + return; +} + +sub file_touch { + my $file = shift; + + open my $fh, '>', $file or syserr(g_('cannot create file %s'), $file); + close $fh or syserr(g_('cannot write %s'), $file); +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Getopt.pm b/scripts/Dpkg/Getopt.pm new file mode 100644 index 0000000..e68e29b --- /dev/null +++ b/scripts/Dpkg/Getopt.pm @@ -0,0 +1,70 @@ +# Copyright © 2014 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Getopt - option parsing handling + +=head1 DESCRIPTION + +This module provides helper functions for option parsing, and complements +the system Getopt::Long module. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Getopt 0.02; + +use strict; +use warnings; + +our @EXPORT = qw( + normalize_options +); + +use Exporter qw(import); + +sub normalize_options +{ + my (%opts) = @_; + my $norm = 1; + my @args; + + @args = map { + if ($norm and m/^(-[A-Za-z])(.+)$/) { + ($1, $2) + } elsif ($norm and m/^(--[A-Za-z-]+)=(.*)$/) { + ($1, $2) + } else { + $norm = 0 if defined $opts{delim} and $_ eq $opts{delim}; + $_; + } + } @{$opts{args}}; + + return @args; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Gettext.pm b/scripts/Dpkg/Gettext.pm new file mode 100644 index 0000000..b814b61 --- /dev/null +++ b/scripts/Dpkg/Gettext.pm @@ -0,0 +1,228 @@ +# Based on Debconf::Gettext. +# +# Copyright © 2000 Joey Hess <joeyh@debian.org> +# Copyright © 2006 Nicolas François <nicolas.francois@centraliens.net> +# Copyright © 2007-2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Gettext - convenience wrapper around Locale::gettext + +=head1 DESCRIPTION + +The Dpkg::Gettext module is a convenience wrapper over the L<Locale::gettext> +module, to guarantee we always have working gettext functions, and to add +some commonly used aliases. + +=cut + +package Dpkg::Gettext 2.01; + +use strict; +use warnings; +use feature qw(state); + +our @EXPORT = qw( + textdomain + gettext + ngettext + g_ + P_ + N_ +); + +use Exporter qw(import); + +=head1 ENVIRONMENT + +=over 4 + +=item DPKG_NLS + +When set to 0, this environment variable will disable the National Language +Support in all Dpkg modules. + +=back + +=head1 VARIABLES + +=over 4 + +=item $Dpkg::Gettext::DEFAULT_TEXT_DOMAIN + +Specifies the default text domain name to be used with the short function +aliases. This is intended to be used by the Dpkg modules, so that they +can produce localized messages even when the calling program has set the +current domain with textdomain(). If you would like to use the aliases +for your own modules, you might want to set this variable to undef, or +to another domain, but then the Dpkg modules will not produce localized +messages. + +=back + +=cut + +our $DEFAULT_TEXT_DOMAIN = 'dpkg-dev'; + +=head1 FUNCTIONS + +=over 4 + +=item $domain = textdomain($new_domain) + +Compatibility textdomain() fallback when L<Locale::gettext> is not available. + +If $new_domain is not undef, it will set the current domain to $new_domain. +Returns the current domain, after possibly changing it. + +=item $trans = gettext($msgid) + +Compatibility gettext() fallback when L<Locale::gettext> is not available. + +Returns $msgid. + +=item $trans = ngettext($msgid, $msgid_plural, $n) + +Compatibility ngettext() fallback when L<Locale::gettext> is not available. + +Returns $msgid if $n is 1 or $msgid_plural otherwise. + +=item $trans = g_($msgid) + +Calls dgettext() on the $msgid and returns its translation for the current +locale. If dgettext() is not available, simply returns $msgid. + +=item $trans = C_($msgctxt, $msgid) + +Calls dgettext() on the $msgid and returns its translation for the specific +$msgctxt supplied. If dgettext() is not available, simply returns $msgid. + +=item $trans = P_($msgid, $msgid_plural, $n) + +Calls dngettext(), returning the correct translation for the plural form +dependent on $n. If dngettext() is not available, returns $msgid if $n is 1 +or $msgid_plural otherwise. + +=cut + +use constant GETTEXT_CONTEXT_GLUE => "\004"; + +BEGIN { + my $use_gettext = $ENV{DPKG_NLS} // 1; + if ($use_gettext) { + eval q{ + use Locale::gettext; + }; + $use_gettext = not $@; + } + if (not $use_gettext) { + *g_ = sub { + return shift; + }; + *textdomain = sub { + my $new_domain = shift; + state $domain = $DEFAULT_TEXT_DOMAIN; + + $domain = $new_domain if defined $new_domain; + + return $domain; + }; + *gettext = sub { + my $msgid = shift; + return $msgid; + }; + *ngettext = sub { + my ($msgid, $msgid_plural, $n) = @_; + if ($n == 1) { + return $msgid; + } else { + return $msgid_plural; + } + }; + *C_ = sub { + my ($msgctxt, $msgid) = @_; + return $msgid; + }; + *P_ = sub { + return ngettext(@_); + }; + } else { + *g_ = sub { + return dgettext($DEFAULT_TEXT_DOMAIN, shift); + }; + *C_ = sub { + my ($msgctxt, $msgid) = @_; + return dgettext($DEFAULT_TEXT_DOMAIN, + $msgctxt . GETTEXT_CONTEXT_GLUE . $msgid); + }; + *P_ = sub { + return dngettext($DEFAULT_TEXT_DOMAIN, @_); + }; + } +} + +=item $msgid = N_($msgid) + +A pseudo function that servers as a marker for automated extraction of +messages, but does not call gettext(). The run-time translation is done +at a different place in the code. + +=back + +=cut + +sub N_ +{ + my $msgid = shift; + return $msgid; +} + +=head1 CHANGES + +=head2 Version 2.01 (dpkg 1.21.10) + +New function: gettext(). + +=head2 Version 2.00 (dpkg 1.20.0) + +Remove function: _g(). + +=head2 Version 1.03 (dpkg 1.19.0) + +New envvar: Add support for new B<DPKG_NLS> environment variable. + +=head2 Version 1.02 (dpkg 1.18.3) + +New function: N_(). + +=head2 Version 1.01 (dpkg 1.18.0) + +Now the short aliases (g_ and P_) will call domain aware functions with +$DEFAULT_TEXT_DOMAIN. + +New functions: g_(), C_(). + +Deprecated function: _g(). + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/IPC.pm b/scripts/Dpkg/IPC.pm new file mode 100644 index 0000000..8af359b --- /dev/null +++ b/scripts/Dpkg/IPC.pm @@ -0,0 +1,421 @@ +# Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008 Frank Lichtenheld <djpig@debian.org> +# Copyright © 2008-2010, 2012-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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::IPC - helper functions for IPC + +=head1 DESCRIPTION + +Dpkg::IPC offers helper functions to allow you to execute +other programs in an easy, yet flexible way, while hiding +all the gory details of IPC (Inter-Process Communication) +from you. + +=cut + +package Dpkg::IPC 1.02; + +use strict; +use warnings; + +our @EXPORT = qw( + spawn + wait_child +); + +use Carp; +use Exporter qw(import); + +use Dpkg::ErrorHandling; +use Dpkg::Gettext; + +=head1 FUNCTIONS + +=over 4 + +=item $pid = spawn(%opts) + +Creates a child process and executes another program in it. +The arguments are interpreted as a hash of options, specifying +how to handle the in and output of the program to execute. +Returns the pid of the child process (unless the wait_child +option was given). + +Any error will cause the function to exit with one of the +L<Dpkg::ErrorHandling> functions. + +Options: + +=over 4 + +=item exec + +Can be either a scalar, i.e. the name of the program to be +executed, or an array reference, i.e. the name of the program +plus additional arguments. Note that the program will never be +executed via the shell, so you can't specify additional arguments +in the scalar string and you can't use any shell facilities like +globbing. + +Mandatory Option. + +=item from_file, to_file, error_to_file + +Filename as scalar. Standard input/output/error of the +child process will be redirected to the file specified. + +=item from_handle, to_handle, error_to_handle + +Filehandle. Standard input/output/error of the child process will be +dup'ed from the handle. + +=item from_pipe, to_pipe, error_to_pipe + +Scalar reference or object based on L<IO::Handle>. A pipe will be opened for +each of the two options and either the reading (C<to_pipe> and +C<error_to_pipe>) or the writing end (C<from_pipe>) will be returned in +the referenced scalar. Standard input/output/error of the child process +will be dup'ed to the other ends of the pipes. + +=item from_string, to_string, error_to_string + +Scalar reference. Standard input/output/error of the child +process will be redirected to the string given as reference. Note +that it wouldn't be strictly necessary to use a scalar reference +for C<from_string>, as the string is not modified in any way. This was +chosen only for reasons of symmetry with C<to_string> and +C<error_to_string>. C<to_string> and C<error_to_string> imply the +C<wait_child> option. + +=item wait_child + +Scalar. If containing a true value, wait_child() will be called before +returning. The return value of spawn() will be a true value, not the pid. + +=item nocheck + +Scalar. Option of the wait_child() call. + +=item timeout + +Scalar. Option of the wait_child() call. + +=item chdir + +Scalar. The child process will chdir in the indicated directory before +calling exec. + +=item env + +Hash reference. The child process will populate %ENV with the items of the +hash before calling exec. This allows exporting environment variables. + +=item delete_env + +Array reference. The child process will remove all environment variables +listed in the array before calling exec. + +=item sig + +Hash reference. The child process will populate %SIG with the items of the +hash before calling exec. This allows setting signal dispositions. + +=item delete_sig + +Array reference. The child process will reset all signals listed in the +array to their default dispositions before calling exec. + +=back + +=cut + +sub _check_opts { + my (%opts) = @_; + + croak 'exec parameter is mandatory in spawn()' + unless $opts{exec}; + + my $to = my $error_to = my $from = 0; + foreach my $thing (qw(file handle string pipe)) { + $to++ if $opts{"to_$thing"}; + $error_to++ if $opts{"error_to_$thing"}; + $from++ if $opts{"from_$thing"}; + } + croak 'not more than one of to_* parameters is allowed' + if $to > 1; + croak 'not more than one of error_to_* parameters is allowed' + if $error_to > 1; + croak 'not more than one of from_* parameters is allowed' + if $from > 1; + + foreach my $param (qw(to_string error_to_string from_string)) { + if (exists $opts{$param} and + (not ref $opts{$param} or ref $opts{$param} ne 'SCALAR')) { + croak "parameter $param must be a scalar reference"; + } + } + + foreach my $param (qw(to_pipe error_to_pipe from_pipe)) { + if (exists $opts{$param} and + (not ref $opts{$param} or (ref $opts{$param} ne 'SCALAR' and + not $opts{$param}->isa('IO::Handle')))) { + croak "parameter $param must be a scalar reference or " . + 'an IO::Handle object'; + } + } + + if (exists $opts{timeout} and defined($opts{timeout}) and + $opts{timeout} !~ /^\d+$/) { + croak 'parameter timeout must be an integer'; + } + + if (exists $opts{env} and ref($opts{env}) ne 'HASH') { + croak 'parameter env must be a hash reference'; + } + + if (exists $opts{delete_env} and ref($opts{delete_env}) ne 'ARRAY') { + croak 'parameter delete_env must be an array reference'; + } + + if (exists $opts{sig} and ref($opts{sig}) ne 'HASH') { + croak 'parameter sig must be a hash reference'; + } + + if (exists $opts{delete_sig} and ref($opts{delete_sig}) ne 'ARRAY') { + croak 'parameter delete_sig must be an array reference'; + } + + return %opts; +} + +sub spawn { + my (%opts) = @_; + my @prog; + + _check_opts(%opts); + $opts{close_in_child} //= []; + if (ref($opts{exec}) =~ /ARRAY/) { + push @prog, @{$opts{exec}}; + } elsif (not ref($opts{exec})) { + push @prog, $opts{exec}; + } else { + croak 'invalid exec parameter in spawn()'; + } + my ($from_string_pipe, $to_string_pipe, $error_to_string_pipe); + if ($opts{to_string}) { + $opts{to_pipe} = \$to_string_pipe; + $opts{wait_child} = 1; + } + if ($opts{error_to_string}) { + $opts{error_to_pipe} = \$error_to_string_pipe; + $opts{wait_child} = 1; + } + if ($opts{from_string}) { + $opts{from_pipe} = \$from_string_pipe; + } + # Create pipes if needed + my ($input_pipe, $output_pipe, $error_pipe); + if ($opts{from_pipe}) { + pipe($opts{from_handle}, $input_pipe) + or syserr(g_('pipe for %s'), "@prog"); + ${$opts{from_pipe}} = $input_pipe; + push @{$opts{close_in_child}}, $input_pipe; + } + if ($opts{to_pipe}) { + pipe($output_pipe, $opts{to_handle}) + or syserr(g_('pipe for %s'), "@prog"); + ${$opts{to_pipe}} = $output_pipe; + push @{$opts{close_in_child}}, $output_pipe; + } + if ($opts{error_to_pipe}) { + pipe($error_pipe, $opts{error_to_handle}) + or syserr(g_('pipe for %s'), "@prog"); + ${$opts{error_to_pipe}} = $error_pipe; + push @{$opts{close_in_child}}, $error_pipe; + } + # Fork and exec + my $pid = fork(); + syserr(g_('cannot fork for %s'), "@prog") unless defined $pid; + if (not $pid) { + # Define environment variables + if ($opts{env}) { + foreach (keys %{$opts{env}}) { + $ENV{$_} = $opts{env}{$_}; + } + } + if ($opts{delete_env}) { + delete $ENV{$_} foreach (@{$opts{delete_env}}); + } + # Define signal dispositions. + if ($opts{sig}) { + foreach (keys %{$opts{sig}}) { + $SIG{$_} = $opts{sig}{$_}; + } + } + if ($opts{delete_sig}) { + delete $SIG{$_} foreach (@{$opts{delete_sig}}); + } + # Change the current directory + if ($opts{chdir}) { + chdir($opts{chdir}) or syserr(g_('chdir to %s'), $opts{chdir}); + } + # Redirect STDIN if needed + if ($opts{from_file}) { + open(STDIN, '<', $opts{from_file}) + or syserr(g_('cannot open %s'), $opts{from_file}); + } elsif ($opts{from_handle}) { + open(STDIN, '<&', $opts{from_handle}) + or syserr(g_('reopen stdin')); + # has been duped, can be closed + push @{$opts{close_in_child}}, $opts{from_handle}; + } + # Redirect STDOUT if needed + if ($opts{to_file}) { + open(STDOUT, '>', $opts{to_file}) + or syserr(g_('cannot write %s'), $opts{to_file}); + } elsif ($opts{to_handle}) { + open(STDOUT, '>&', $opts{to_handle}) + or syserr(g_('reopen stdout')); + # has been duped, can be closed + push @{$opts{close_in_child}}, $opts{to_handle}; + } + # Redirect STDERR if needed + if ($opts{error_to_file}) { + open(STDERR, '>', $opts{error_to_file}) + or syserr(g_('cannot write %s'), $opts{error_to_file}); + } elsif ($opts{error_to_handle}) { + open(STDERR, '>&', $opts{error_to_handle}) + or syserr(g_('reopen stdout')); + # has been duped, can be closed + push @{$opts{close_in_child}}, $opts{error_to_handle}; + } + # Close some inherited filehandles + close($_) foreach (@{$opts{close_in_child}}); + # Execute the program + exec({ $prog[0] } @prog) or syserr(g_('unable to execute %s'), "@prog"); + } + # Close handle that we can't use any more + close($opts{from_handle}) if exists $opts{from_handle}; + close($opts{to_handle}) if exists $opts{to_handle}; + close($opts{error_to_handle}) if exists $opts{error_to_handle}; + + if ($opts{from_string}) { + print { $from_string_pipe } ${$opts{from_string}}; + close($from_string_pipe); + } + if ($opts{to_string}) { + local $/ = undef; + ${$opts{to_string}} = readline($to_string_pipe); + } + if ($opts{error_to_string}) { + local $/ = undef; + ${$opts{error_to_string}} = readline($error_to_string_pipe); + } + if ($opts{wait_child}) { + my $cmdline = "@prog"; + if ($opts{env}) { + foreach (keys %{$opts{env}}) { + $cmdline = "$_=\"" . $opts{env}{$_} . "\" $cmdline"; + } + } + wait_child($pid, nocheck => $opts{nocheck}, + timeout => $opts{timeout}, cmdline => $cmdline); + return 1; + } + + return $pid; +} + + +=item wait_child($pid, %opts) + +Takes as first argument the pid of the process to wait for. +Remaining arguments are taken as a hash of options. Returns +nothing. Fails if the child has been ended by a signal or +if it exited non-zero. + +Options: + +=over 4 + +=item cmdline + +String to identify the child process in error messages. +Defaults to "child process". + +=item nocheck + +If true do not check the return status of the child (and thus +do not fail it has been killed or if it exited with a +non-zero return code). + +=item timeout + +Set a maximum time to wait for the process, after that kill the process and +fail with an error message. + +=back + +=cut + +sub wait_child { + my ($pid, %opts) = @_; + $opts{cmdline} //= g_('child process'); + croak 'no PID set, cannot wait end of process' unless $pid; + eval { + local $SIG{ALRM} = sub { die "alarm\n" }; + alarm($opts{timeout}) if defined($opts{timeout}); + $pid == waitpid($pid, 0) or syserr(g_('wait for %s'), $opts{cmdline}); + alarm(0) if defined($opts{timeout}); + }; + if ($@) { + die $@ unless $@ eq "alarm\n"; + kill 'TERM', $pid; + error(P_("%s didn't complete in %d second", + "%s didn't complete in %d seconds", + $opts{timeout}), + $opts{cmdline}, $opts{timeout}); + } + unless ($opts{nocheck}) { + subprocerr($opts{cmdline}) if $?; + } +} + +1; + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.18.0) + +Change options: wait_child() now kills the process when reaching the 'timeout'. + +=head2 Version 1.01 (dpkg 1.17.11) + +New options: spawn() now accepts 'sig' and 'delete_sig'. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=head1 SEE ALSO + +L<Dpkg>, L<Dpkg::ErrorHandling>. diff --git a/scripts/Dpkg/Index.pm b/scripts/Dpkg/Index.pm new file mode 100644 index 0000000..3f898af --- /dev/null +++ b/scripts/Dpkg/Index.pm @@ -0,0 +1,457 @@ +# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2012-2017 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Index - generic index of control information + +=head1 DESCRIPTION + +This class represent a set of L<Dpkg::Control> objects. + +=cut + +package Dpkg::Index 3.00; + +use strict; +use warnings; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control; + +use parent qw(Dpkg::Interface::Storable); + +use overload + '@{}' => sub { return $_[0]->{order} }, + fallback => 1; + +=head1 METHODS + +=over 4 + +=item $index = Dpkg::Index->new(%opts) + +Creates a new empty index. See set_options() for more details. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = { + items => {}, + order => [], + unique_tuple_key => 1, + get_key_func => sub { return $_[0]->{Package} }, + type => CTRL_UNKNOWN, + item_opts => {}, + }; + bless $self, $class; + $self->set_options(%opts); + if (exists $opts{load}) { + $self->load($opts{load}); + } + + return $self; +} + +=item $index->set_options(%opts) + +The "type" option is checked first to define default values for other +options. Here are the relevant options: "get_key_func" is a function +returning a key for the item passed in parameters, "unique_tuple_key" is +a boolean requesting whether the default key should be the unique tuple +(default to true), "item_opts" is a hash reference that will be passed to +the item constructor in the new_item() method. +The index can only contain one item with a given key. +The "get_key_func" function used depends on the type: + +=over + +=item * + +for CTRL_TMPL_SRC, it is the Source field; + +=item * + +for CTRL_REPO_SRC and CTRL_DSC it is the Package and Version fields +(concatenated with "_") when "unique_tuple_key" is true (the default), or +otherwise the Package field; + +=item * + +for CTRL_TMPL_PKG it is simply the Package field; + +=item * + +for CTRL_REPO_PKG and CTRL_DEB it is the Package, Version and +Architecture fields (concatenated with "_") when "unique_tuple_key" is +true (the default) or otherwise the Package field; + +=item * + +for CTRL_CHANGELOG it is the Source and the Version fields (concatenated +with an intermediary "_"); + +=item * + +for CTRL_TESTS is an integer index (0-based) corresponding to the Tests or +Test-Command field stanza; + +=item * + +for CTRL_FILE_CHANGES it is the Source, Version and Architecture fields +(concatenated with "_"); + +=item * + +for CTRL_FILE_VENDOR it is the Vendor field; + +=item * + +for CTRL_FILE_STATUS it is the Package and Architecture fields (concatenated +with "_"); + +=item * + +otherwise it is the Package field by default. + +=back + +=cut + +sub set_options { + my ($self, %opts) = @_; + + # Default values based on type + if (exists $opts{type}) { + my $t = $opts{type}; + if ($t == CTRL_TMPL_PKG) { + $self->{get_key_func} = sub { return $_[0]->{Package}; }; + } elsif ($t == CTRL_TMPL_SRC) { + $self->{get_key_func} = sub { return $_[0]->{Source}; }; + } elsif ($t == CTRL_CHANGELOG) { + $self->{get_key_func} = sub { + return $_[0]->{Source} . '_' . $_[0]->{Version}; + }; + } elsif ($t == CTRL_COPYRIGHT_HEADER) { + # This is a bit pointless, because the value will almost always + # be the same, but guarantees that we use a known field. + $self->{get_key_func} = sub { return $_[0]->{Format}; }; + } elsif ($t == CTRL_COPYRIGHT_FILES) { + $self->{get_key_func} = sub { return $_[0]->{Files}; }; + } elsif ($t == CTRL_COPYRIGHT_LICENSE) { + $self->{get_key_func} = sub { return $_[0]->{License}; }; + } elsif ($t == CTRL_TESTS) { + $self->{get_key_func} = sub { + return scalar @{$self->{order}}; + }; + } elsif ($t == CTRL_REPO_SRC or $t == CTRL_DSC) { + if ($opts{unique_tuple_key} // $self->{unique_tuple_key}) { + $self->{get_key_func} = sub { + return $_[0]->{Package} . '_' . $_[0]->{Version}; + }; + } else { + $self->{get_key_func} = sub { + return $_[0]->{Package}; + }; + } + } elsif ($t == CTRL_REPO_PKG or $t == CTRL_DEB) { + if ($opts{unique_tuple_key} // $self->{unique_tuple_key}) { + $self->{get_key_func} = sub { + return $_[0]->{Package} . '_' . $_[0]->{Version} . '_' . + $_[0]->{Architecture}; + }; + } else { + $self->{get_key_func} = sub { + return $_[0]->{Package}; + }; + } + } elsif ($t == CTRL_FILE_CHANGES) { + $self->{get_key_func} = sub { + return $_[0]->{Source} . '_' . $_[0]->{Version} . '_' . + $_[0]->{Architecture}; + }; + } elsif ($t == CTRL_FILE_VENDOR) { + $self->{get_key_func} = sub { return $_[0]->{Vendor}; }; + } elsif ($t == CTRL_FILE_STATUS) { + $self->{get_key_func} = sub { + return $_[0]->{Package} . '_' . $_[0]->{Architecture}; + }; + } + } + + # Options set by the user override default values + $self->{$_} = $opts{$_} foreach keys %opts; +} + +=item $index->get_type() + +Returns the type of control information stored. See the type parameter +set during new(). + +=cut + +sub get_type { + my $self = shift; + return $self->{type}; +} + +=item $index->add($item, [$key]) + +Add a new item in the index. If the $key parameter is omitted, the key +will be generated with the get_key_func function (see set_options() for +details). + +=cut + +sub add { + my ($self, $item, $key) = @_; + + $key //= $self->{get_key_func}($item); + if (not exists $self->{items}{$key}) { + push @{$self->{order}}, $key; + } + $self->{items}{$key} = $item; +} + +=item $index->parse($fh, $desc) + +Reads the filehandle and creates all items parsed. When called multiple +times, the parsed stanzas are accumulated. + +Returns the number of items parsed. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + my $item = $self->new_item(); + my $i = 0; + while ($item->parse($fh, $desc)) { + $self->add($item); + $item = $self->new_item(); + $i++; + } + return $i; +} + +=item $index->load($file) + +Reads the file and creates all items parsed. Returns the number of items +parsed. Handles compressed files transparently based on their extensions. + +=item $item = $index->new_item() + +Creates a new item. Mainly useful for derived objects that would want +to override this method to return something else than a L<Dpkg::Control> +object. + +=cut + +sub new_item { + my $self = shift; + return Dpkg::Control->new(%{$self->{item_opts}}, type => $self->{type}); +} + +=item $item = $index->get_by_key($key) + +Returns the item identified by $key or undef. + +=cut + +sub get_by_key { + my ($self, $key) = @_; + return $self->{items}{$key} if exists $self->{items}{$key}; + return; +} + +=item @keys = $index->get_keys(%criteria) + +Returns the keys of items that matches all the criteria. The key of the +%criteria hash is a field name and the value is either a regex that needs +to match the field value, or a reference to a function that must return +true and that receives the field value as single parameter, or a scalar +that must be equal to the field value. + +=cut + +sub get_keys { + my ($self, %crit) = @_; + my @selected = @{$self->{order}}; + foreach my $s_crit (keys %crit) { # search criteria + if (ref($crit{$s_crit}) eq 'Regexp') { + @selected = grep { + exists $self->{items}{$_}{$s_crit} and + $self->{items}{$_}{$s_crit} =~ $crit{$s_crit} + } @selected; + } elsif (ref($crit{$s_crit}) eq 'CODE') { + @selected = grep { + $crit{$s_crit}->($self->{items}{$_}{$s_crit}); + } @selected; + } else { + @selected = grep { + exists $self->{items}{$_}{$s_crit} and + $self->{items}{$_}{$s_crit} eq $crit{$s_crit} + } @selected; + } + } + return @selected; +} + +=item @items = $index->get(%criteria) + +Returns all the items that matches all the criteria. + +=cut + +sub get { + my ($self, %crit) = @_; + return map { $self->{items}{$_} } $self->get_keys(%crit); +} + +=item $index->remove_by_key($key) + +Remove the item identified by the given key. + +=cut + +sub remove_by_key { + my ($self, $key) = @_; + @{$self->{order}} = grep { $_ ne $key } @{$self->{order}}; + return delete $self->{items}{$key}; +} + +=item @items = $index->remove(%criteria) + +Returns and removes all the items that matches all the criteria. + +=cut + +sub remove { + my ($self, %crit) = @_; + my @keys = $self->get_keys(%crit); + my (%keys, @ret); + foreach my $key (@keys) { + $keys{$key} = 1; + push @ret, $self->{items}{$key} if defined wantarray; + delete $self->{items}{$key}; + } + @{$self->{order}} = grep { not exists $keys{$_} } @{$self->{order}}; + return @ret; +} + +=item $index->merge($other_index, %opts) + +Merge the entries of the other index. While merging, the keys of the merged +index are used, they are not re-computed (unless you have set the options +"keep_keys" to "0"). It's your responsibility to ensure that they have been +computed with the same function. + +=cut + +sub merge { + my ($self, $other, %opts) = @_; + $opts{keep_keys} //= 1; + foreach my $key ($other->get_keys()) { + $self->add($other->get_by_key($key), $opts{keep_keys} ? $key : undef); + } +} + +=item $index->sort(\&sortfunc) + +Sort the index with the given sort function. If no function is given, an +alphabetic sort is done based on the keys. The sort function receives the +items themselves as parameters and not the keys. + +=cut + +sub sort { + my ($self, $func) = @_; + if (defined $func) { + @{$self->{order}} = sort { + $func->($self->{items}{$a}, $self->{items}{$b}) + } @{$self->{order}}; + } else { + @{$self->{order}} = sort @{$self->{order}}; + } +} + +=item $str = $index->output([$fh]) + +=item "$index" + +Get a string representation of the index. The L<Dpkg::Control> objects are +output in the order which they have been read or added except if the order +have been changed with sort(). + +Print the string representation of the index to a filehandle if $fh has +been passed. + +=cut + +sub output { + my ($self, $fh) = @_; + my $str = ''; + foreach my $key ($self->get_keys()) { + if (defined $fh) { + print { $fh } $self->get_by_key($key) . "\n"; + } + if (defined wantarray) { + $str .= $self->get_by_key($key) . "\n"; + } + } + return $str; +} + +=item $index->save($file) + +Writes the content of the index in a file. Auto-compresses files +based on their extensions. + +=back + +=head1 CHANGES + +=head2 Version 3.00 (dpkg 1.21.2) + +Change behavior: The CTRL_TESTS key now defaults to a stanza index. + +=head2 Version 2.01 (dpkg 1.20.6) + +New option: Add new "item_opts" option. + +=head2 Version 2.00 (dpkg 1.20.0) + +Change behavior: The "unique_tuple_key" option now defaults to true. + +=head2 Version 1.01 (dpkg 1.19.0) + +New option: Add new "unique_tuple_key" option to $index->set_options() to set +better default "get_key_func" options, which will become the default behavior +in 1.20.x. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Interface/Storable.pm b/scripts/Dpkg/Interface/Storable.pm new file mode 100644 index 0000000..65eadf0 --- /dev/null +++ b/scripts/Dpkg/Interface/Storable.pm @@ -0,0 +1,163 @@ +# Copyright © 2010 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Interface::Storable - common methods related to object serialization + +=head1 DESCRIPTION + +Dpkg::Interface::Storable is only meant to be used as parent +class for other classes. It provides common methods that are +all implemented on top of two basic methods parse() and output(). + +=cut + +package Dpkg::Interface::Storable 1.01; + +use strict; +use warnings; + +use Carp; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +use overload + '""' => \&_stringify, + 'fallback' => 1; + +=head1 BASE METHODS + +Those methods must be provided by the class that wish to inherit +from Dpkg::Interface::Storable so that the methods provided can work. + +=over 4 + +=item $obj->parse($fh[, $desc]) + +This methods initialize the object with the data stored in the +filehandle. $desc is optional and is a textual description of +the filehandle used in error messages. + +=item $string = $obj->output([$fh]) + +This method returns a string representation of the object in $string +and it writes the same string to $fh (if it's defined). + +=back + +=head1 PROVIDED METHODS + +=over 4 + +=item $obj->load($filename, %opts) + +Initialize the object with the data stored in the file. The file can be +compressed, it will be decompressed on the fly by using a +L<Dpkg::Compression::FileHandle> object. If $opts{compression} is false the +decompression support will be disabled. If $filename is "-", then the +standard input is read (no compression is allowed in that case). + +=cut + +sub load { + my ($self, $file, %opts) = @_; + $opts{compression} //= 1; + unless ($self->can('parse')) { + croak ref($self) . ' cannot be loaded, it lacks the parse method'; + } + my ($desc, $fh) = ($file, undef); + if ($file eq '-') { + $fh = \*STDIN; + $desc = g_('<standard input>'); + } else { + if ($opts{compression}) { + require Dpkg::Compression::FileHandle; + $fh = Dpkg::Compression::FileHandle->new(); + } + open($fh, '<', $file) or syserr(g_('cannot read %s'), $file); + } + my $res = $self->parse($fh, $desc, %opts); + if ($file ne '-') { + close($fh) or syserr(g_('cannot close %s'), $file); + } + return $res; +} + +=item $obj->save($filename, %opts) + +Store the object in the file. If the filename ends with a known +compression extension, it will be compressed on the fly by using a +L<Dpkg::Compression::FileHandle> object. If $opts{compression} is false the +compression support will be disabled. If $filename is "-", then the +standard output is used (data are written uncompressed in that case). + +=cut + +sub save { + my ($self, $file, %opts) = @_; + $opts{compression} //= 1; + unless ($self->can('output')) { + croak ref($self) . ' cannot be saved, it lacks the output method'; + } + my $fh; + if ($file eq '-') { + $fh = \*STDOUT; + } else { + if ($opts{compression}) { + require Dpkg::Compression::FileHandle; + $fh = Dpkg::Compression::FileHandle->new(); + } + open($fh, '>', $file) or syserr(g_('cannot write %s'), $file); + } + $self->output($fh, %opts); + if ($file ne '-') { + close($fh) or syserr(g_('cannot close %s'), $file); + } +} + +=item "$obj" + +Return a string representation of the object. + +=cut + +sub _stringify { + my $self = shift; + unless ($self->can('output')) { + croak ref($self) . ' cannot be stringified, it lacks the output method'; + } + return $self->output(); +} + +=back + +=head1 CHANGES + +=head2 Version 1.01 (dpkg 1.19.0) + +New options: The $obj->load() and $obj->save() methods support a new +compression option. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Lock.pm b/scripts/Dpkg/Lock.pm new file mode 100644 index 0000000..176a670 --- /dev/null +++ b/scripts/Dpkg/Lock.pm @@ -0,0 +1,81 @@ +# Copyright © 2011 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2012 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Lock - file locking support + +=head1 DESCRIPTION + +This module implements locking functions used to support parallel builds. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Lock 0.01; + +use strict; +use warnings; + +our @EXPORT = qw( + file_lock +); + +use Exporter qw(import); +use Fcntl qw(:flock); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +sub file_lock($$) { + my ($fh, $filename) = @_; + + # A strict dependency on libfile-fcntllock-perl being it an XS module, + # and dpkg-dev indirectly making use of it, makes building new perl + # package which bump the perl ABI impossible as these packages cannot + # be installed alongside. + eval q{ + use File::FcntlLock; + }; + if ($@) { + # On Linux systems the flock() locks get converted to file-range + # locks on NFS mounts. + if ($^O ne 'linux') { + warning(g_('File::FcntlLock not available; using flock which is not NFS-safe')); + } + flock($fh, LOCK_EX) + or syserr(g_('failed to get a write lock on %s'), $filename); + } else { + eval q{ + my $fs = File::FcntlLock->new(l_type => F_WRLCK); + $fs->lock($fh, F_SETLKW) + or syserr(g_('failed to get a write lock on %s'), $filename); + } + } +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/OpenPGP.pm b/scripts/Dpkg/OpenPGP.pm new file mode 100644 index 0000000..1118d22 --- /dev/null +++ b/scripts/Dpkg/OpenPGP.pm @@ -0,0 +1,174 @@ +# Copyright © 2017 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::OpenPGP - multi-backend OpenPGP support + +=head1 DESCRIPTION + +This module provides a class for transparent multi-backend OpenPGP support. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::OpenPGP 0.01; + +use strict; +use warnings; + +use List::Util qw(none); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::IPC; +use Dpkg::Path qw(find_command); + +my @BACKENDS = qw( + sop + sq + gpg +); +my %BACKEND = ( + sop => 'SOP', + sq => 'Sequoia', + gpg => 'GnuPG', +); + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = {}; + bless $self, $class; + + my $backend = $opts{backend} // 'auto'; + my %backend_opts = ( + cmdv => $opts{cmdv} // 'auto', + cmd => $opts{cmd} // 'auto', + ); + + if ($backend eq 'auto') { + # Defaults for stateless full API auto-detection. + $opts{needs}{api} //= 'full'; + $opts{needs}{keystore} //= 0; + + if (none { $opts{needs}{api} eq $_ } qw(full verify)) { + error(g_('unknown OpenPGP api requested %s'), $opts{needs}{api}); + } + + $self->{backend} = $self->_auto_backend($opts{needs}, %backend_opts); + } elsif (exists $BACKEND{$backend}) { + $self->{backend} = $self->_load_backend($BACKEND{$backend}, %backend_opts); + if (! $self->{backend}) { + error(g_('cannot load OpenPGP backend %s'), $backend); + } + } else { + error(g_('unknown OpenPGP backend %s'), $backend); + } + + return $self; +} + +sub _load_backend { + my ($self, $backend, %opts) = @_; + + my $module = "Dpkg::OpenPGP::Backend::$backend"; + eval qq{ + require $module; + }; + return if $@; + + return $module->new(%opts); +} + +sub _auto_backend { + my ($self, $needs, %opts) = @_; + + foreach my $backend (@BACKENDS) { + my $module = $self->_load_backend($BACKEND{$backend}, %opts); + + if ($needs->{api} eq 'verify') { + next if ! $module->has_verify_cmd(); + } else { + next if ! $module->has_backend_cmd(); + } + next if $needs->{keystore} && ! $module->has_keystore(); + + return $module; + } + + # Otherwise load a dummy backend. + return Dpkg::OpenPGP::Backend->new(); +} + +sub can_use_secrets { + my ($self, $key) = @_; + + return 0 unless $self->{backend}->has_backend_cmd(); + return 0 if $key->type eq 'keyfile' && ! -f $key->handle; + return 0 if $key->type eq 'keystore' && ! -e $key->handle; + return 0 unless $self->{backend}->can_use_key($key); + return 1; +} + +sub get_trusted_keyrings { + my $self = shift; + + return $self->{backend}->get_trusted_keyrings(); +} + +sub armor { + my ($self, $type, $in, $out) = @_; + + return $self->{backend}->armor($type, $in, $out); +} + +sub dearmor { + my ($self, $type, $in, $out) = @_; + + return $self->{backend}->dearmor($type, $in, $out); +} + +sub inline_verify { + my ($self, $inlinesigned, $data, @certs) = @_; + + return $self->{backend}->inline_verify($inlinesigned, $data, @certs); +} + +sub verify { + my ($self, $data, $sig, @certs) = @_; + + return $self->{backend}->verify($data, $sig, @certs); +} + +sub inline_sign { + my ($self, $data, $inlinesigned, $key) = @_; + + return $self->{backend}->inline_sign($data, $inlinesigned, $key); +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/OpenPGP/Backend.pm b/scripts/Dpkg/OpenPGP/Backend.pm new file mode 100644 index 0000000..52be10e --- /dev/null +++ b/scripts/Dpkg/OpenPGP/Backend.pm @@ -0,0 +1,146 @@ +# Copyright © 2017, 2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::OpenPGP::Backend - OpenPGP backend base class + +=head1 DESCRIPTION + +This module provides an OpenPGP backend base class that specific +implementations should inherit from. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::OpenPGP::Backend 0.01; + +use strict; +use warnings; + +use List::Util qw(first); + +use Dpkg::Path qw(find_command); +use Dpkg::OpenPGP::ErrorCodes; + +sub DEFAULT_CMDV { + return []; +} + +sub DEFAULT_CMDSTORE { + return []; +} + +sub DEFAULT_CMD { + return []; +} + +sub _detect_cmd { + my ($cmd, $default) = @_; + + if (! defined $cmd || $cmd eq 'auto') { + return first { find_command($_) } @{$default}; + } else { + return find_command($cmd); + } +} + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = {}; + bless $self, $class; + + $self->{cmdv} = _detect_cmd($opts{cmdv}, $self->DEFAULT_CMDV()); + $self->{cmdstore} = _detect_cmd($opts{cmdstore}, $self->DEFAULT_CMDSTORE()); + $self->{cmd} = _detect_cmd($opts{cmd}, $self->DEFAULT_CMD()); + + return $self; +} + +sub has_backend_cmd { + my $self = shift; + + return defined $self->{cmd}; +} + +sub has_verify_cmd { + my $self = shift; + + return defined $self->{cmd}; +} + +sub has_keystore { + my $self = shift; + + return 0; +} + +sub can_use_key { + my ($self, $key) = @_; + + return $self->has_keystore() if $key->needs_keystore(); + return 1; +} + +sub get_trusted_keyrings { + my $self = shift; + + return (); +} + +sub armor { + my ($self, $type, $in, $out) = @_; + + return OPENPGP_UNSUPPORTED_SUBCMD; +} + +sub dearmor { + my ($self, $type, $in, $out) = @_; + + return OPENPGP_UNSUPPORTED_SUBCMD; +} + +sub inline_verify { + my ($self, $inlinesigned, $data, @certs) = @_; + + return OPENPGP_UNSUPPORTED_SUBCMD; +} + +sub verify { + my ($self, $data, $sig, @certs) = @_; + + return OPENPGP_UNSUPPORTED_SUBCMD; +} + +sub inline_sign { + my ($self, $data, $inlinesigned, $key) = @_; + + return OPENPGP_UNSUPPORTED_SUBCMD; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/OpenPGP/Backend/GnuPG.pm b/scripts/Dpkg/OpenPGP/Backend/GnuPG.pm new file mode 100644 index 0000000..9c53ef1 --- /dev/null +++ b/scripts/Dpkg/OpenPGP/Backend/GnuPG.pm @@ -0,0 +1,334 @@ +# Copyright © 2007, 2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::OpenPGP::Backend::GnuPG - OpenPGP backend for GnuPG + +=head1 DESCRIPTION + +This module provides a class that implements the OpenPGP backend +for GnuPG. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::OpenPGP::Backend::GnuPG 0.01; + +use strict; +use warnings; + +use POSIX qw(:sys_wait_h); +use File::Temp; +use MIME::Base64; + +use Dpkg::ErrorHandling; +use Dpkg::IPC; +use Dpkg::File; +use Dpkg::Path qw(find_command); +use Dpkg::OpenPGP::ErrorCodes; + +use parent qw(Dpkg::OpenPGP::Backend); + +sub DEFAULT_CMDV { + return [ qw(gpgv) ]; +} + +sub DEFAULT_CMDSTORE { + return [ qw(gpg-agent) ]; +} + +sub DEFAULT_CMD { + return [ qw(gpg) ]; +} + +sub has_backend_cmd { + my $self = shift; + + return defined $self->{cmd} && defined $self->{cmdstore}; +} + +sub has_keystore { + my $self = shift; + + return 0 if not defined $self->{cmdstore}; + return 1 if ($ENV{GNUPGHOME} && -e $ENV{GNUPGHOME}) || + ($ENV{HOME} && -e "$ENV{HOME}/.gnupg"); + return 0; +} + +sub can_use_key { + my ($self, $key) = @_; + + # With gpg, a secret key always requires gpg-agent (the key store). + return $self->has_keystore(); +} + +sub has_verify_cmd { + my $self = shift; + + return defined $self->{cmdv} || defined $self->{cmd}; +} + +sub get_trusted_keyrings { + my $self = shift; + + my $keystore; + if ($ENV{GNUPGHOME} && -e $ENV{GNUPGHOME}) { + $keystore = $ENV{GNUPGHOME}; + } elsif ($ENV{HOME} && -e "$ENV{HOME}/.gnupg") { + $keystore = "$ENV{HOME}/.gnupg"; + } else { + return; + } + + my @keyrings; + foreach my $keyring (qw(trustedkeys.kbx trustedkeys.gpg)) { + push @keyrings, "$keystore/$keyring" if -r "$keystore/$keyring"; + } + return @keyrings; +} + +# _pgp_* functions are strictly for applying or removing ASCII armor. +# See <https://datatracker.ietf.org/doc/html/rfc4880#section-6> for more +# details. +# +# Note that these _pgp_* functions are only necessary while relying on +# gpgv, and gpgv itself does not verify multiple signatures correctly +# (see https://bugs.debian.org/1010955). + +sub _pgp_dearmor_data { + my ($type, $data) = @_; + + # Note that we ignore an incorrect or absent checksum, following the + # guidance of + # <https://datatracker.ietf.org/doc/draft-ietf-openpgp-crypto-refresh/>. + my $armor_regex = qr{ + -----BEGIN\ PGP\ \Q$type\E-----[\r\t ]*\n + (?:[^:]+:\ [^\n]*[\r\t ]*\n)* + [\r\t ]*\n + ([a-zA-Z0-9/+\n]+={0,2})[\r\t ]*\n + (?:=[a-zA-Z0-9/+]{4}[\r\t ]*\n)? + -----END\ PGP\ \Q$type\E----- + }xm; + + if ($data =~ m/$armor_regex/) { + return decode_base64($1); + } + return; +} + +sub _pgp_armor_checksum { + my ($data) = @_; + + # From the upcoming revision to RFC 4880 + # <https://datatracker.ietf.org/doc/draft-ietf-openpgp-crypto-refresh/>. + # + # The resulting three-octet-wide value then gets base64-encoded into + # four base64 ASCII characters. + + my $CRC24_INIT = 0xB704CE; + my $CRC24_GENERATOR = 0x864CFB; + + my @bytes = unpack 'C*', $data; + my $crc = $CRC24_INIT; + for my $b (@bytes) { + $crc ^= ($b << 16); + for (1 .. 8) { + $crc <<= 1; + if ($crc & 0x1000000) { + # Clear bit 25 to avoid overflow. + $crc &= 0xffffff; + $crc ^= $CRC24_GENERATOR; + } + } + } + my $sum = pack 'CCC', ($crc >> 16) & 0xff, ($crc >> 8) & 0xff, $crc & 0xff; + return encode_base64($sum, q{}); +} + +sub _pgp_armor_data { + my ($type, $data) = @_; + + my $out = encode_base64($data, q{}) =~ s/(.{1,64})/$1\n/gr; + chomp $out; + my $crc = _pgp_armor_checksum($data); + my $armor = <<~"ARMOR"; + -----BEGIN PGP $type----- + + $out + =$crc + -----END PGP $type----- + ARMOR + return $armor; +} + +sub armor { + my ($self, $type, $in, $out) = @_; + + my $raw_data = file_slurp($in); + my $data = _pgp_dearmor_data($type, $raw_data) // $raw_data; + my $armor = _pgp_armor_data($type, $data); + return OPENPGP_BAD_DATA unless defined $armor; + file_dump($out, $armor); + + return OPENPGP_OK; +} + +sub dearmor { + my ($self, $type, $in, $out) = @_; + + my $armor = file_slurp($in); + my $data = _pgp_dearmor_data($type, $armor); + return OPENPGP_BAD_DATA unless defined $data; + file_dump($out, $data); + + return OPENPGP_OK; +} + +sub _gpg_exec +{ + my ($self, @exec) = @_; + + my ($stdout, $stderr); + spawn(exec => \@exec, wait_child => 1, nocheck => 1, timeout => 10, + to_string => \$stdout, error_to_string => \$stderr); + if (WIFEXITED($?)) { + my $status = WEXITSTATUS($?); + print { *STDERR } "$stdout$stderr" if $status; + return $status; + } else { + subprocerr("@exec"); + } +} + +sub _gpg_options_weak_digests { + my @gpg_weak_digests = map { + (qw(--weak-digest), $_) + } qw(SHA1 RIPEMD160); + + return @gpg_weak_digests; +} + +sub _gpg_verify { + my ($self, $signeddata, $sig, $data, @certs) = @_; + + return OPENPGP_MISSING_CMD if ! $self->has_verify_cmd(); + + my $gpg_home = File::Temp->newdir('dpkg-gpg-verify.XXXXXXXX', TMPDIR => 1); + my @cmd_opts = qw(--no-options --no-default-keyring --batch --quiet); + my @gpg_opts; + push @gpg_opts, _gpg_options_weak_digests(); + push @gpg_opts, '--homedir', $gpg_home; + push @cmd_opts, @gpg_opts; + + my @exec; + if ($self->{cmdv}) { + push @exec, $self->{cmdv}; + push @exec, @gpg_opts; + # We need to touch the trustedkeys.gpg keyring, otherwise gpgv will + # emit an error about the trustedkeys.kbx file being of unknown type. + file_touch("$gpg_home/trustedkeys.gpg"); + } else { + push @exec, $self->{cmd}; + push @exec, @cmd_opts; + } + foreach my $cert (@certs) { + my $certring = File::Temp->new(UNLINK => 1, SUFFIX => '.pgp'); + my $rc; + # XXX: The internal dearmor() does not handle concatenated ASCII Armor, + # but the old implementation handled such certificate keyrings, so to + # avoid regressing for now, we fallback to use the GnuPG dearmor. + if ($cert =~ m{\.kbx$}) { + # Accept GnuPG apparent keybox-format keyrings as-is. + $rc = 1; + } elsif (defined $self->{cmd}) { + $rc = $self->_gpg_exec($self->{cmd}, @cmd_opts, '--yes', + '--output', $certring, + '--dearmor', $cert); + } else { + $rc = $self->dearmor('PUBLIC KEY BLOCK', $cert, $certring); + } + $certring = $cert if $rc; + push @exec, '--keyring', $certring; + } + push @exec, '--output', $data if defined $data; + if (! $self->{cmdv}) { + push @exec, '--verify'; + } + push @exec, $sig if defined $sig; + push @exec, $signeddata; + + my $rc = $self->_gpg_exec(@exec); + return OPENPGP_NO_SIG if $rc; + return OPENPGP_OK; +} + +sub inline_verify { + my ($self, $inlinesigned, $data, @certs) = @_; + + return $self->_gpg_verify($inlinesigned, undef, $data, @certs); +} + +sub verify { + my ($self, $data, $sig, @certs) = @_; + + return $self->_gpg_verify($data, $sig, undef, @certs); +} + +sub inline_sign { + my ($self, $data, $inlinesigned, $key) = @_; + + return OPENPGP_MISSING_CMD if ! $self->has_backend_cmd(); + + my @exec = ($self->{cmd}); + push @exec, _gpg_options_weak_digests(); + push @exec, qw(--utf8-strings --textmode --armor); + # Set conformance level. + push @exec, '--openpgp'; + # Set secure algorithm preferences. + push @exec, '--personal-digest-preferences', 'SHA512 SHA384 SHA256 SHA224'; + if ($key->type eq 'keyfile') { + # Promote the keyfile keyhandle to a keystore, this way we share the + # same gpg-agent and can get any password cached. + my $gpg_home = File::Temp->newdir('dpkg-sign.XXXXXXXX', TMPDIR => 1); + + push @exec, '--homedir', $gpg_home; + $self->_gpg_exec(@exec, qw(--quiet --no-tty --batch --import), $key->handle); + $key->set('keystore', $gpg_home); + } elsif ($key->type eq 'keystore') { + push @exec, '--homedir', $key->handle; + } else { + push @exec, '--local-user', $key->handle; + } + push @exec, '--output', $inlinesigned; + + my $rc = $self->_gpg_exec(@exec, '--clearsign', $data); + return OPENPGP_CMD_CANNOT_SIGN if $rc; + return OPENPGP_OK; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/OpenPGP/Backend/SOP.pm b/scripts/Dpkg/OpenPGP/Backend/SOP.pm new file mode 100644 index 0000000..f48cec9 --- /dev/null +++ b/scripts/Dpkg/OpenPGP/Backend/SOP.pm @@ -0,0 +1,132 @@ +# Copyright © 2021-2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::OpenPGP::Backend::SOP - OpenPGP backend for SOP + +=head1 DESCRIPTION + +This module provides a class that implements the OpenPGP backend +for the Stateless OpenPGP Command-Line Interface, as described in +L<https://datatracker.ietf.org/doc/draft-dkg-openpgp-stateless-cli>. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::OpenPGP::Backend::SOP 0.01; + +use strict; +use warnings; + +use POSIX qw(:sys_wait_h); + +use Dpkg::ErrorHandling; +use Dpkg::IPC; +use Dpkg::OpenPGP::ErrorCodes; + +use parent qw(Dpkg::OpenPGP::Backend); + +# - Once "gosop" implements inline-verify and inline-sign, add as alternative. +# Ref: https://github.com/ProtonMail/gosop/issues/6 +# - Once "gosop" can handle big keyrings. +# Ref: https://github.com/ProtonMail/gosop/issues/25 +# - Once "hop" implements the new SOP draft, add as alternative. +# Ref: https://salsa.debian.org/clint/hopenpgp-tools/-/issues/4 +# - Once the SOP MR !23 is finalized and merged, implement a way to select +# whether the SOP instance supports the expected draft. +# Ref: https://gitlab.com/dkg/openpgp-stateless-cli/-/merge_requests/23 +# - Once the SOP issue #42 is resolved we can perhaps remove the alternative +# dependencies and commands to check? +# Ref: https://gitlab.com/dkg/openpgp-stateless-cli/-/issues/42 + +sub DEFAULT_CMD { + return [ qw(sqop pgpainless-cli) ]; +} + +sub _sop_exec +{ + my ($self, $io, @exec) = @_; + + return OPENPGP_MISSING_CMD unless $self->{cmd}; + + $io->{out} //= '/dev/null'; + my $stderr; + spawn(exec => [ $self->{cmd}, @exec ], + wait_child => 1, nocheck => 1, timeout => 10, + from_file => $io->{in}, to_file => $io->{out}, + error_to_string => \$stderr); + if (WIFEXITED($?)) { + my $status = WEXITSTATUS($?); + print { *STDERR } "$stderr" if $status; + return $status; + } else { + subprocerr("$self->{cmd} @exec"); + } +} + +sub armor +{ + my ($self, $type, $in, $out) = @_; + + # We ignore the $type, and let "sop" handle this automatically. + return $self->_sop_exec({ in => $in, out => $out }, 'armor'); +} + +sub dearmor +{ + my ($self, $type, $in, $out) = @_; + + # We ignore the $type, and let "sop" handle this automatically. + return $self->_sop_exec({ in => $in, out => $out }, 'dearmor'); +} + +sub inline_verify +{ + my ($self, $inlinesigned, $data, @certs) = @_; + + return $self->_sop_exec({ in => $inlinesigned, out => $data }, + 'inline-verify', @certs); +} + +sub verify +{ + my ($self, $data, $sig, @certs) = @_; + + return $self->_sop_exec({ in => $data }, 'verify', $sig, @certs); +} + +sub inline_sign +{ + my ($self, $data, $inlinesigned, $key) = @_; + + return OPENPGP_NEEDS_KEYSTORE if $key->needs_keystore(); + + return $self->_sop_exec({ in => $data, out => $inlinesigned }, + qw(inline-sign --as clearsigned --), $key->handle); +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/OpenPGP/Backend/Sequoia.pm b/scripts/Dpkg/OpenPGP/Backend/Sequoia.pm new file mode 100644 index 0000000..ae4acc1 --- /dev/null +++ b/scripts/Dpkg/OpenPGP/Backend/Sequoia.pm @@ -0,0 +1,144 @@ +# Copyright © 2021-2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::OpenPGP::Backend::Sequoia - OpenPGP backend for Sequoia + +=head1 DESCRIPTION + +This module provides a class that implements the OpenPGP backend +for Sequoia-PGP. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::OpenPGP::Backend::Sequoia 0.01; + +use strict; +use warnings; + +use POSIX qw(:sys_wait_h); + +use Dpkg::ErrorHandling; +use Dpkg::IPC; +use Dpkg::OpenPGP::ErrorCodes; + +use parent qw(Dpkg::OpenPGP::Backend); + +sub DEFAULT_CMD { + return [ qw(sq) ]; +} + +sub _sq_exec +{ + my ($self, @exec) = @_; + + my ($stdout, $stderr); + spawn(exec => [ $self->{cmd}, @exec ], + wait_child => 1, nocheck => 1, timeout => 10, + to_string => \$stdout, error_to_string => \$stderr); + if (WIFEXITED($?)) { + my $status = WEXITSTATUS($?); + print { *STDERR } "$stdout$stderr" if $status; + return $status; + } else { + subprocerr("$self->{cmd} @exec"); + } +} + +sub armor +{ + my ($self, $type, $in, $out) = @_; + + return OPENPGP_MISSING_CMD unless $self->{cmd}; + + # We ignore the $type, and let "sq" handle this automatically. + my $rc = $self->_sq_exec(qw(armor --output), $out, $in); + return OPENPGP_BAD_DATA if $rc; + return OPENPGP_OK; +} + +sub dearmor +{ + my ($self, $type, $in, $out) = @_; + + return OPENPGP_MISSING_CMD unless $self->{cmd}; + + # We ignore the $type, and let "sq" handle this automatically. + my $rc = $self->_sq_exec(qw(dearmor --output), $out, $in); + return OPENPGP_BAD_DATA if $rc; + return OPENPGP_OK; +} + +sub inline_verify +{ + my ($self, $inlinesigned, $data, @certs) = @_; + + return OPENPGP_MISSING_CMD unless $self->{cmd}; + + my @opts; + push @opts, map { ('--signer-file', $_) } @certs; + push @opts, '--output', $data if defined $data; + + my $rc = $self->_sq_exec(qw(verify), @opts, $inlinesigned); + return OPENPGP_NO_SIG if $rc; + return OPENPGP_OK; +} + +sub verify +{ + my ($self, $data, $sig, @certs) = @_; + + return OPENPGP_MISSING_CMD unless $self->{cmd}; + + my @opts; + push @opts, map { ('--signer-file', $_) } @certs; + push @opts, '--detached', $sig; + + my $rc = $self->_sq_exec(qw(verify), @opts, $data); + return OPENPGP_NO_SIG if $rc; + return OPENPGP_OK; +} + +sub inline_sign +{ + my ($self, $data, $inlinesigned, $key) = @_; + + return OPENPGP_MISSING_CMD unless $self->{cmd}; + return OPENPGP_NEEDS_KEYSTORE if $key->needs_keystore(); + + my @opts; + push @opts, '--cleartext-signature'; + push @opts, '--signer-file', $key->handle; + push @opts, '--output', $inlinesigned; + + my $rc = $self->_sq_exec('sign', @opts, $data); + return OPENPGP_KEY_CANNOT_SIGN if $rc; + return OPENPGP_OK; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/OpenPGP/ErrorCodes.pm b/scripts/Dpkg/OpenPGP/ErrorCodes.pm new file mode 100644 index 0000000..0db59aa --- /dev/null +++ b/scripts/Dpkg/OpenPGP/ErrorCodes.pm @@ -0,0 +1,118 @@ +# Copyright © 2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::OpenPGP::ErrorCodes - OpenPGP error codes + +=head1 DESCRIPTION + +This module provides error codes handling to be used by the various +OpenPGP backends. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::OpenPGP::ErrorCodes 0.01; + +use strict; +use warnings; + +our @EXPORT = qw( + OPENPGP_OK + OPENPGP_NO_SIG + OPENPGP_MISSING_ARG + OPENPGP_UNSUPPORTED_OPTION + OPENPGP_BAD_DATA + OPENPGP_EXPECTED_TEXT + OPENPGP_OUTPUT_EXISTS + OPENPGP_MISSING_INPUT + OPENPGP_KEY_IS_PROTECTED + OPENPGP_UNSUPPORTED_SUBCMD + OPENPGP_KEY_CANNOT_SIGN + + OPENPGP_MISSING_CMD + OPENPGP_NEEDS_KEYSTORE + OPENPGP_CMD_CANNOT_SIGN + + openpgp_errorcode_to_string +); + +use Exporter qw(import); + +use Dpkg::Gettext; + +# Error codes based on +# https://ietf.org/archive/id/draft-dkg-openpgp-stateless-cli-04.html#section-6 +# +# Local error codes use a negative number, as that should not conflict with +# the SOP exit codes. + +use constant { + OPENPGP_OK => 0, + OPENPGP_NO_SIG => 3, + OPENPGP_MISSING_ARG => 19, + OPENPGP_UNSUPPORTED_OPTION => 37, + OPENPGP_BAD_DATA => 41, + OPENPGP_EXPECTED_TEXT => 53, + OPENPGP_OUTPUT_EXISTS => 59, + OPENPGP_MISSING_INPUT => 61, + OPENPGP_KEY_IS_PROTECTED => 67, + OPENPGP_UNSUPPORTED_SUBCMD => 69, + OPENPGP_KEY_CANNOT_SIGN => 79, + + OPENPGP_MISSING_CMD => -1, + OPENPGP_NEEDS_KEYSTORE => -2, + OPENPGP_CMD_CANNOT_SIGN => -3, +}; + +my %code2error = ( + OPENPGP_OK() => N_('success'), + OPENPGP_NO_SIG() => N_('no acceptable signature found'), + OPENPGP_MISSING_ARG() => N_('missing required argument'), + OPENPGP_UNSUPPORTED_OPTION() => N_('unsupported option'), + OPENPGP_BAD_DATA() => N_('invalid data type'), + OPENPGP_EXPECTED_TEXT() => N_('non-text input where text expected'), + OPENPGP_OUTPUT_EXISTS() => N_('output file already exists'), + OPENPGP_MISSING_INPUT() => N_('input file does not exist'), + OPENPGP_KEY_IS_PROTECTED() => N_('cannot unlock password-protected key'), + OPENPGP_UNSUPPORTED_SUBCMD() => N_('unsupported subcommand'), + OPENPGP_KEY_CANNOT_SIGN() => N_('key is not signature-capable'), + + OPENPGP_MISSING_CMD() => N_('missing OpenPGP implementation'), + OPENPGP_NEEDS_KEYSTORE() => N_('specified key needs a keystore'), + OPENPGP_CMD_CANNOT_SIGN() => N_('OpenPGP backend command cannot sign'), +); + +sub openpgp_errorcode_to_string +{ + my $code = shift; + + return gettext($code2error{$code}) if exists $code2error{$code}; + return sprintf g_('error code %d'), $code; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/OpenPGP/KeyHandle.pm b/scripts/Dpkg/OpenPGP/KeyHandle.pm new file mode 100644 index 0000000..9c843e4 --- /dev/null +++ b/scripts/Dpkg/OpenPGP/KeyHandle.pm @@ -0,0 +1,124 @@ +# Copyright © 2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::OpenPGP::KeyHandle - OpenPGP key handle support + +=head1 DESCRIPTION + +This module provides a class to hold an OpenPGP key handle, as a way for +the code to refer to a key in an independent way. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::OpenPGP::KeyHandle 0.01; + +use strict; +use warnings; + +use Carp; +use List::Util qw(any none); + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = { + type => $opts{type} // 'auto', + handle => $opts{handle}, + }; + bless $self, $class; + + $self->_sanitize(); + + return $self; +} + +my $keyid_regex = qr/^(?:0x)?([[:xdigit:]]+)$/; + +sub _sanitize { + my ($self) = shift; + + my $type = $self->{type}; + if ($type eq 'auto') { + if (-e $self->{handle}) { + $type = 'keyfile'; + } else { + $type = 'autoid'; + } + } + + if ($type eq 'autoid') { + if ($self->{handle} =~ m/$keyid_regex/) { + $self->{handle} = $1; + $type = 'keyid'; + } else { + $type = 'userid'; + } + $self->{type} = $type; + } elsif ($type eq 'keyid') { + if ($self->{handle} =~ m/$keyid_regex/) { + $self->{handle} = $1; + } + } + + if (none { $type eq $_ } qw(userid keyid keyfile keystore)) { + croak "unknown type parameter value $type"; + } + + return; +} + +sub needs_keystore { + my $self = shift; + + return any { $self->{type} eq $_ } qw(keyid userid); +} + +sub set { + my ($self, $type, $handle) = @_; + + $self->{type} = $type; + $self->{handle} = $handle; + + $self->_sanitize(); +} + +sub type { + my $self = shift; + + return $self->{type}; +} + +sub handle { + my $self = shift; + + return $self->{handle}; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Package.pm b/scripts/Dpkg/Package.pm new file mode 100644 index 0000000..4741a6f --- /dev/null +++ b/scripts/Dpkg/Package.pm @@ -0,0 +1,96 @@ +# Copyright © 2006 Frank Lichtenheld <djpig@debian.org> +# Copyright © 2007-2009, 2012-2013 Guillem Jover <guillem@debian.org> +# Copyright © 2007 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Package - package properties handling + +=head1 DESCRIPTION + +This module provides functions to parse and validate package properties. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Package 0.01; + +use strict; +use warnings; + +our @EXPORT = qw( + pkg_name_is_illegal + + get_source_name + set_source_name +); + +use Exporter qw(import); + +use Dpkg::ErrorHandling; +use Dpkg::Gettext; + +sub pkg_name_is_illegal($) { + my $name = shift // ''; + + if ($name eq '') { + return g_('may not be empty string'); + } + if ($name =~ m/[^-+.0-9a-z]/op) { + return sprintf(g_("character '%s' not allowed"), ${^MATCH}); + } + if ($name !~ m/^[0-9a-z]/o) { + return g_('must start with an alphanumeric character'); + } + + return; +} + +# XXX: Eventually the following functions should be moved as methods for +# Dpkg::Source::Package. + +my $source_name; + +sub get_source_name { + return $source_name; +} + +sub set_source_name { + my $name = shift; + + my $err = pkg_name_is_illegal($name); + error(g_("source package name '%s' is illegal: %s"), $name, $err) if $err; + + if (not defined $source_name) { + $source_name = $name; + } elsif ($name ne $source_name) { + error(g_('source package has two conflicting values - %s and %s'), + $source_name, $name); + } +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Path.pm b/scripts/Dpkg/Path.pm new file mode 100644 index 0000000..ae8c734 --- /dev/null +++ b/scripts/Dpkg/Path.pm @@ -0,0 +1,355 @@ +# Copyright © 2007-2011 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2011 Linaro Limited +# +# 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Path - some common path handling functions + +=head1 DESCRIPTION + +It provides some functions to handle various path. + +=cut + +package Dpkg::Path 1.05; + +use strict; +use warnings; + +our @EXPORT_OK = qw( + canonpath + resolve_symlink + check_files_are_the_same + check_directory_traversal + find_command + find_build_file + get_control_path + get_pkg_root_dir + guess_pkg_root_dir + relative_to_pkg_root +); + +use Exporter qw(import); +use Errno qw(ENOENT); +use File::Spec; +use File::Find; +use Cwd qw(realpath); + +use Dpkg::ErrorHandling; +use Dpkg::Gettext; +use Dpkg::Arch qw(get_host_arch debarch_to_debtuple); +use Dpkg::IPC; + +=head1 FUNCTIONS + +=over 8 + +=item get_pkg_root_dir($file) + +This function will scan upwards the hierarchy of directory to find out +the directory which contains the "DEBIAN" sub-directory and it will return +its path. This directory is the root directory of a package being built. + +If no DEBIAN subdirectory is found, it will return undef. + +=cut + +sub get_pkg_root_dir($) { + my $file = shift; + $file =~ s{/+$}{}; + $file =~ s{/+[^/]+$}{} if not -d $file; + while ($file) { + return $file if -d "$file/DEBIAN"; + last if $file !~ m{/}; + $file =~ s{/+[^/]+$}{}; + } + return; +} + +=item relative_to_pkg_root($file) + +Returns the filename relative to get_pkg_root_dir($file). + +=cut + +sub relative_to_pkg_root($) { + my $file = shift; + my $pkg_root = get_pkg_root_dir($file); + if (defined $pkg_root) { + $pkg_root .= '/'; + return $file if ($file =~ s/^\Q$pkg_root\E//); + } + return; +} + +=item guess_pkg_root_dir($file) + +This function tries to guess the root directory of the package build tree. +It will first use get_pkg_root_dir(), but it will fallback to a more +imprecise check: namely it will use the parent directory that is a +sub-directory of the debian directory. + +It can still return undef if a file outside of the debian sub-directory is +provided. + +=cut + +sub guess_pkg_root_dir($) { + my $file = shift; + my $root = get_pkg_root_dir($file); + return $root if defined $root; + + $file =~ s{/+$}{}; + $file =~ s{/+[^/]+$}{} if not -d $file; + my $parent = $file; + while ($file) { + $parent =~ s{/+[^/]+$}{}; + last if not -d $parent; + return $file if check_files_are_the_same('debian', $parent); + $file = $parent; + last if $file !~ m{/}; + } + return; +} + +=item check_files_are_the_same($file1, $file2, $resolve_symlink) + +This function verifies that both files are the same by checking that the device +numbers and the inode numbers returned by stat()/lstat() are the same. If +$resolve_symlink is true then stat() is used, otherwise lstat() is used. + +=cut + +sub check_files_are_the_same($$;$) { + my ($file1, $file2, $resolve_symlink) = @_; + + return 1 if $file1 eq $file2; + return 0 if ((! -e $file1) || (! -e $file2)); + my (@stat1, @stat2); + if ($resolve_symlink) { + @stat1 = stat($file1); + @stat2 = stat($file2); + } else { + @stat1 = lstat($file1); + @stat2 = lstat($file2); + } + my $result = ($stat1[0] == $stat2[0]) && ($stat1[1] == $stat2[1]); + return $result; +} + + +=item canonpath($file) + +This function returns a cleaned path. It simplifies double //, and remove +/./ and /../ intelligently. For /../ it simplifies the path only if the +previous element is not a symlink. Thus it should only be used on real +filenames. + +=cut + +sub canonpath($) { + my $path = shift; + $path = File::Spec->canonpath($path); + my ($v, $dirs, $file) = File::Spec->splitpath($path); + my @dirs = File::Spec->splitdir($dirs); + my @new; + foreach my $d (@dirs) { + if ($d eq '..') { + if (scalar(@new) > 0 and $new[-1] ne '..') { + next if $new[-1] eq ''; # Root directory has no parent + my $parent = File::Spec->catpath($v, + File::Spec->catdir(@new), ''); + if (not -l $parent) { + pop @new; + } else { + push @new, $d; + } + } else { + push @new, $d; + } + } else { + push @new, $d; + } + } + return File::Spec->catpath($v, File::Spec->catdir(@new), $file); +} + +=item $newpath = resolve_symlink($symlink) + +Return the filename of the file pointed by the symlink. The new name is +canonicalized by canonpath(). + +=cut + +sub resolve_symlink($) { + my $symlink = shift; + my $content = readlink($symlink); + return unless defined $content; + if (File::Spec->file_name_is_absolute($content)) { + return canonpath($content); + } else { + my ($link_v, $link_d, $link_f) = File::Spec->splitpath($symlink); + my ($cont_v, $cont_d, $cont_f) = File::Spec->splitpath($content); + my $new = File::Spec->catpath($link_v, $link_d . '/' . $cont_d, $cont_f); + return canonpath($new); + } +} + +=item check_directory_traversal($basedir, $dir) + +This function verifies that the directory $dir does not contain any symlink +that goes beyond $basedir (which should be either equal or a parent of $dir). + +=cut + +sub check_directory_traversal { + my ($basedir, $dir) = @_; + + my $canon_basedir = realpath($basedir); + # On Solaris /dev/null points to /devices/pseudo/mm@0:null. + my $canon_devnull = realpath('/dev/null'); + my $check_symlinks = sub { + my $canon_pathname = realpath($_); + if (not defined $canon_pathname) { + return if $! == ENOENT; + + syserr(g_("pathname '%s' cannot be canonicalized"), $_); + } + return if $canon_pathname eq $canon_devnull; + return if $canon_pathname eq $canon_basedir; + return if $canon_pathname =~ m{^\Q$canon_basedir/\E}; + + error(g_("pathname '%s' points outside source root (to '%s')"), + $_, $canon_pathname); + }; + + find({ + wanted => $check_symlinks, + no_chdir => 1, + follow => 1, + follow_skip => 2, + }, $dir); + + return; +} + +=item $cmdpath = find_command($command) + +Return the path of the command if defined and available on an absolute or +relative path or on the $PATH, undef otherwise. + +=cut + +sub find_command($) { + my $cmd = shift; + + return if not $cmd; + if ($cmd =~ m{/}) { + return "$cmd" if -x "$cmd"; + } else { + foreach my $dir (split(/:/, $ENV{PATH})) { + return "$dir/$cmd" if -x "$dir/$cmd"; + } + } + return; +} + +=item $control_file = get_control_path($pkg, $filetype) + +Return the path of the control file of type $filetype for the given +package. + +=item @control_files = get_control_path($pkg) + +Return the path of all available control files for the given package. + +=cut + +sub get_control_path($;$) { + my ($pkg, $filetype) = @_; + my $control_file; + my @exec = ('dpkg-query', '--control-path', $pkg); + push @exec, $filetype if defined $filetype; + spawn(exec => \@exec, wait_child => 1, to_string => \$control_file); + chomp($control_file); + if (defined $filetype) { + return if $control_file eq ''; + return $control_file; + } + return () if $control_file eq ''; + return split(/\n/, $control_file); +} + +=item $file = find_build_file($basename) + +Selects the right variant of the given file: the arch-specific variant +("$basename.$arch") has priority over the OS-specific variant +("$basename.$os") which has priority over the default variant +("$basename"). If none of the files exists, then it returns undef. + +=item @files = find_build_file($basename) + +Return the available variants of the given file. Returns an empty +list if none of the files exists. + +=cut + +sub find_build_file($) { + my $base = shift; + my $host_arch = get_host_arch(); + my ($abi, $libc, $host_os, $cpu) = debarch_to_debtuple($host_arch); + my @files; + foreach my $fn ("$base.$host_arch", "$base.$host_os", "$base") { + push @files, $fn if -f $fn; + } + return @files if wantarray; + return $files[0] if scalar @files; + return; +} + +=back + +=head1 CHANGES + +=head2 Version 1.05 (dpkg 1.20.4) + +New function: check_directory_traversal(). + +=head2 Version 1.04 (dpkg 1.17.11) + +Update semantics: find_command() now handles an empty or undef argument. + +=head2 Version 1.03 (dpkg 1.16.1) + +New function: find_build_file() + +=head2 Version 1.02 (dpkg 1.16.0) + +New function: get_control_path() + +=head2 Version 1.01 (dpkg 1.15.8) + +New function: find_command() + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Shlibs.pm b/scripts/Dpkg/Shlibs.pm new file mode 100644 index 0000000..9c245ec --- /dev/null +++ b/scripts/Dpkg/Shlibs.pm @@ -0,0 +1,212 @@ +# Copyright © 2007, 2016 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2007-2008, 2012-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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Shlibs - shared library location handling + +=head1 DESCRIPTION + +This module provides functions to locate shared libraries. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Shlibs 0.03; + +use strict; +use warnings; +use feature qw(state); + +our @EXPORT_OK = qw( + blank_library_paths + setup_library_paths + get_library_paths + add_library_dir + find_library +); + +use Exporter qw(import); +use List::Util qw(none); +use File::Spec; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Shlibs::Objdump; +use Dpkg::BuildAPI qw(get_build_api); +use Dpkg::Path qw(resolve_symlink canonpath); +use Dpkg::Arch qw(get_build_arch get_host_arch :mappers); + +use constant DEFAULT_LIBRARY_PATH => + qw(/lib /usr/lib); +# XXX: Deprecated multilib paths. +use constant DEFAULT_MULTILIB_PATH => + qw(/lib32 /usr/lib32 /lib64 /usr/lib64); + +# Library paths set by the user. +my @custom_librarypaths; +# Library paths from the system. +my @system_librarypaths; +my $librarypaths_init; + +sub parse_ldso_conf { + my $file = shift; + state %visited; + local $_; + + open my $fh, '<', $file or syserr(g_('cannot open %s'), $file); + $visited{$file}++; + while (<$fh>) { + next if /^\s*$/; + chomp; + s{/+$}{}; + if (/^include\s+(\S.*\S)\s*$/) { + foreach my $include (glob($1)) { + parse_ldso_conf($include) if -e $include + && !$visited{$include}; + } + } elsif (m{^\s*/}) { + s/^\s+//; + my $libdir = $_; + if (none { $_ eq $libdir } (@custom_librarypaths, @system_librarypaths)) { + push @system_librarypaths, $libdir; + } + } + } + close $fh; +} + +sub blank_library_paths { + @custom_librarypaths = (); + @system_librarypaths = (); + $librarypaths_init = 1; +} + +sub setup_library_paths { + @custom_librarypaths = (); + @system_librarypaths = (); + + # XXX: Deprecated. Update library paths with LD_LIBRARY_PATH. + if ($ENV{LD_LIBRARY_PATH}) { + require Cwd; + my $cwd = Cwd::getcwd; + + foreach my $path (split /:/, $ENV{LD_LIBRARY_PATH}) { + $path =~ s{/+$}{}; + + my $realpath = Cwd::realpath($path); + next unless defined $realpath; + if ($realpath =~ m/^\Q$cwd\E/) { + if (get_build_api() >= 1) { + error(g_('use -l option instead of LD_LIBRARY_PATH')); + } else { + warning(g_('deprecated use of LD_LIBRARY_PATH with private ' . + 'library directory which interferes with ' . + 'cross-building, please use -l option instead')); + } + } + + next if get_build_api() >= 1; + + # XXX: This should be added to @custom_librarypaths, but as this + # is deprecated we do not care as the code will go away. + push @system_librarypaths, $path; + } + } + + # Adjust set of directories to consider when we're in a situation of a + # cross-build or a build of a cross-compiler. + my $multiarch; + + # Detect cross compiler builds. + if ($ENV{DEB_TARGET_GNU_TYPE} and + ($ENV{DEB_TARGET_GNU_TYPE} ne $ENV{DEB_BUILD_GNU_TYPE})) + { + $multiarch = gnutriplet_to_multiarch($ENV{DEB_TARGET_GNU_TYPE}); + } + # Host for normal cross builds. + if (get_build_arch() ne get_host_arch()) { + $multiarch = debarch_to_multiarch(get_host_arch()); + } + # Define list of directories containing crossbuilt libraries. + if ($multiarch) { + push @system_librarypaths, "/lib/$multiarch", "/usr/lib/$multiarch"; + } + + push @system_librarypaths, DEFAULT_LIBRARY_PATH; + + # Update library paths with ld.so config. + parse_ldso_conf('/etc/ld.so.conf') if -e '/etc/ld.so.conf'; + + push @system_librarypaths, DEFAULT_MULTILIB_PATH; + + $librarypaths_init = 1; +} + +sub add_library_dir { + my $dir = shift; + + setup_library_paths() if not $librarypaths_init; + + push @custom_librarypaths, $dir; +} + +sub get_library_paths { + setup_library_paths() if not $librarypaths_init; + + return (@custom_librarypaths, @system_librarypaths); +} + +# find_library ($soname, \@rpath, $format, $root) +sub find_library { + my ($lib, $rpath, $format, $root) = @_; + + setup_library_paths() if not $librarypaths_init; + + my @librarypaths = (@{$rpath}, @custom_librarypaths, @system_librarypaths); + my @libs; + + $root //= ''; + $root =~ s{/+$}{}; + foreach my $dir (@librarypaths) { + my $checkdir = "$root$dir"; + if (-e "$checkdir/$lib") { + my $libformat = Dpkg::Shlibs::Objdump::get_format("$checkdir/$lib"); + if (not defined $libformat) { + warning(g_("unknown executable format in file '%s'"), "$checkdir/$lib"); + } elsif ($format eq $libformat) { + push @libs, canonpath("$checkdir/$lib"); + } else { + debug(1, "Skipping lib $checkdir/$lib, libabi=<%s> != objabi=<%s>", + $libformat, $format); + } + } + } + return @libs; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Shlibs/Cppfilt.pm b/scripts/Dpkg/Shlibs/Cppfilt.pm new file mode 100644 index 0000000..1f054a1 --- /dev/null +++ b/scripts/Dpkg/Shlibs/Cppfilt.pm @@ -0,0 +1,142 @@ +# Copyright © 2009-2010 Modestas Vainius <modax@debian.org> +# Copyright © 2010, 2012-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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Shlibs::Cppfilt - C++ symbol mangling support via c++filt + +=head1 DESCRIPTION + +This module provides functions that wrap over c++filt for its easy and +fast usage. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Shlibs::Cppfilt 0.01; + +use strict; +use warnings; + +our @EXPORT = qw( + cppfilt_demangle_cpp +); +our @EXPORT_OK = qw( + cppfilt_demangle +); + +use Exporter qw(import); + +use Dpkg::ErrorHandling; +use Dpkg::IPC; + +# A hash of 'objects' referring to preforked c++filt processes for the distinct +# demangling types. +my %cppfilts; + +sub get_cppfilt { + my $type = shift || 'auto'; + + # Fork c++filt process for demangling $type unless it is forked already. + # Keeping c++filt running improves performance a lot. + my $filt; + if (exists $cppfilts{$type}) { + $filt = $cppfilts{$type}; + } else { + $filt = { + from => undef, + to => undef, + last_symbol => '', + last_result => '', + }; + $filt->{pid} = spawn(exec => [ 'c++filt', "--format=$type" ], + from_pipe => \$filt->{from}, + to_pipe => \$filt->{to}); + syserr(g_('unable to execute %s'), 'c++filt') + unless defined $filt->{from}; + $filt->{from}->autoflush(1); + + $cppfilts{$type} = $filt; + } + return $filt; +} + +# Demangle the given $symbol using demangler for the specified $type (defaults +# to 'auto') . Extraneous characters trailing after a mangled name are kept +# intact. If neither whole $symbol nor portion of it could be demangled, undef +# is returned. +sub cppfilt_demangle { + my ($symbol, $type) = @_; + + # Start or get c++filt 'object' for the requested type. + my $filt = get_cppfilt($type); + + # Remember the last result. Such a local optimization is cheap and useful + # when sequential pattern matching is performed. + if ($filt->{last_symbol} ne $symbol) { + # This write/read operation should not deadlock because c++filt flushes + # output buffer on LF or each invalid character. + print { $filt->{from} } $symbol, "\n"; + my $demangled = readline($filt->{to}); + chop $demangled; + + # If the symbol was not demangled, return undef + $demangled = undef if $symbol eq $demangled; + + # Remember the last result + $filt->{last_symbol} = $symbol; + $filt->{last_result} = $demangled; + } + return $filt->{last_result}; +} + +sub cppfilt_demangle_cpp { + my $symbol = shift; + return cppfilt_demangle($symbol, 'auto'); +} + +sub terminate_cppfilts { + foreach my $type (keys %cppfilts) { + next if not defined $cppfilts{$type}{pid}; + close $cppfilts{$type}{from}; + close $cppfilts{$type}{to}; + wait_child($cppfilts{$type}{pid}, cmdline => 'c++filt', + nocheck => 1, + timeout => 5); + delete $cppfilts{$type}; + } +} + +# Close/terminate running c++filt process(es) +END { + # Make sure exitcode is not changed (by wait_child) + my $exitcode = $?; + terminate_cppfilts(); + $? = $exitcode; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Shlibs/Objdump.pm b/scripts/Dpkg/Shlibs/Objdump.pm new file mode 100644 index 0000000..bc2909c --- /dev/null +++ b/scripts/Dpkg/Shlibs/Objdump.pm @@ -0,0 +1,310 @@ +# Copyright © 2007-2010 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2007-2009,2012-2015,2017-2018 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Shlibs::Objdump - symbol support via objdump + +=head1 DESCRIPTION + +This module provides a class that wraps objdump to handle symbols and +their attributes from a shared object. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Shlibs::Objdump 0.01; + +use strict; +use warnings; +use feature qw(state); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Shlibs::Objdump::Object; + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = { objects => {} }; + bless $self, $class; + return $self; +} + +sub add_object { + my ($self, $obj) = @_; + my $id = $obj->get_id; + if ($id) { + $self->{objects}{$id} = $obj; + } + return $id; +} + +sub analyze { + my ($self, $file) = @_; + my $obj = Dpkg::Shlibs::Objdump::Object->new($file); + + return $self->add_object($obj); +} + +sub locate_symbol { + my ($self, $name) = @_; + foreach my $obj (values %{$self->{objects}}) { + my $sym = $obj->get_symbol($name); + if (defined($sym) && $sym->{defined}) { + return $sym; + } + } + return; +} + +sub get_object { + my ($self, $objid) = @_; + if ($self->has_object($objid)) { + return $self->{objects}{$objid}; + } + return; +} + +sub has_object { + my ($self, $objid) = @_; + return exists $self->{objects}{$objid}; +} + +use constant { + # ELF Class. + ELF_BITS_NONE => 0, + ELF_BITS_32 => 1, + ELF_BITS_64 => 2, + + # ELF Data encoding. + ELF_ORDER_NONE => 0, + ELF_ORDER_2LSB => 1, + ELF_ORDER_2MSB => 2, + + # ELF Machine. + EM_NONE => 0, + EM_SPARC => 2, + EM_386 => 3, + EM_68K => 4, + EM_MIPS => 8, + EM_SPARC64_OLD => 11, + EM_PARISC => 15, + EM_SPARC32PLUS => 18, + EM_PPC => 20, + EM_PPC64 => 21, + EM_S390 => 22, + EM_ARM => 40, + EM_ALPHA_OLD => 41, + EM_SH => 42, + EM_SPARC64 => 43, + EM_IA64 => 50, + EM_X86_64 => 62, + EM_OR1K => 92, + EM_AARCH64 => 183, + EM_ARCV2 => 195, + EM_RISCV => 243, + EM_LOONGARCH => 258, + EM_OR1K_OLD => 0x8472, + EM_ALPHA => 0x9026, + EM_S390_OLD => 0xa390, + EM_NIOS32 => 0xfebb, + + # ELF Version. + EV_NONE => 0, + EV_CURRENT => 1, + + # ELF Flags (might influence the ABI). + EF_ARM_ALIGN8 => 0x00000040, + EF_ARM_NEW_ABI => 0x00000080, + EF_ARM_OLD_ABI => 0x00000100, + EF_ARM_SOFT_FLOAT => 0x00000200, + EF_ARM_HARD_FLOAT => 0x00000400, + EF_ARM_EABI_MASK => 0xff000000, + + EF_IA64_ABI64 => 0x00000010, + + EF_LOONGARCH_SOFT_FLOAT => 0x00000001, + EF_LOONGARCH_SINGLE_FLOAT => 0x00000002, + EF_LOONGARCH_DOUBLE_FLOAT => 0x00000003, + EF_LOONGARCH_ABI_MASK => 0x00000007, + + EF_MIPS_ABI2 => 0x00000020, + EF_MIPS_32BIT => 0x00000100, + EF_MIPS_FP64 => 0x00000200, + EF_MIPS_NAN2008 => 0x00000400, + EF_MIPS_ABI_MASK => 0x0000f000, + EF_MIPS_ARCH_MASK => 0xf0000000, + + EF_OR1K_NODELAY => 0x00000001, + + EF_PPC64_ABI64 => 0x00000003, + + EF_RISCV_FLOAT_ABI_SOFT => 0x0000, + EF_RISCV_FLOAT_ABI_SINGLE => 0x0002, + EF_RISCV_FLOAT_ABI_DOUBLE => 0x0004, + EF_RISCV_FLOAT_ABI_QUAD => 0x0006, + EF_RISCV_FLOAT_ABI_MASK => 0x0006, + EF_RISCV_RVE => 0x0008, + + EF_SH_MACH_MASK => 0x0000001f, +}; + +# These map machine IDs to their name. +my %elf_mach_name = ( + EM_NONE() => 'none', + EM_386() => 'i386', + EM_68K() => 'm68k', + EM_AARCH64() => 'arm64', + EM_ALPHA() => 'alpha', + EM_ARCV2() => 'arcv2', + EM_ARM() => 'arm', + EM_IA64() => 'ia64', + EM_LOONGARCH() => 'loong', + EM_MIPS() => 'mips', + EM_NIOS32() => 'nios2', + EM_OR1K() => 'or1k', + EM_PARISC() => 'hppa', + EM_PPC() => 'ppc', + EM_PPC64() => 'ppc64', + EM_RISCV() => 'riscv', + EM_S390() => 's390', + EM_SH() => 'sh', + EM_SPARC() => 'sparc', + EM_SPARC64() => 'sparc64', + EM_X86_64() => 'amd64', +); + +# These map alternative or old machine IDs to their canonical form. +my %elf_mach_map = ( + EM_ALPHA_OLD() => EM_ALPHA, + EM_OR1K_OLD() => EM_OR1K, + EM_S390_OLD() => EM_S390, + EM_SPARC32PLUS() => EM_SPARC, + EM_SPARC64_OLD() => EM_SPARC64, +); + +# These masks will try to expose processor flags that are ABI incompatible, +# and as such are part of defining the architecture ABI. If uncertain it is +# always better to not mask a flag, because that preserves the historical +# behavior, and we do not drop dependencies. +my %elf_flags_mask = ( + # XXX: The mask for ARM had to be disabled due to objects in the wild + # with EABIv4, while EABIv5 is the current one, and the soft and hard + # flags not always being set on armel and armhf respectively, although + # the Tag_ABI_VFP_args in the ARM attribute section should always be + # present on armhf, and there are even cases where both soft and hard + # float flags are set at the same time(!). Once these are confirmed to + # be fixed, we could reconsider enabling the below for a more strict + # ABI mismatch check. See #853793. +# EM_ARM() => EF_ARM_EABI_MASK | +# EF_ARM_NEW_ABI | EF_ARM_OLD_ABI | +# EF_ARM_SOFT_FLOAT | EF_ARM_HARD_FLOAT, + EM_IA64() => EF_IA64_ABI64, + EM_LOONGARCH() => EF_LOONGARCH_ABI_MASK, + EM_MIPS() => EF_MIPS_ABI_MASK | EF_MIPS_ABI2, + EM_OR1K() => EF_OR1K_NODELAY, + EM_PPC64() => EF_PPC64_ABI64, + EM_RISCV() => EF_RISCV_FLOAT_ABI_MASK | EF_RISCV_RVE, +); + +sub get_format { + my ($file) = @_; + state %format; + + return $format{$file} if exists $format{$file}; + + my $header; + + open my $fh, '<', $file or syserr(g_('cannot read %s'), $file); + my $rc = read $fh, $header, 64; + if (not defined $rc) { + syserr(g_('cannot read %s'), $file); + } elsif ($rc != 64) { + return; + } + close $fh; + + my %elf; + + # Unpack the identifier field. + @elf{qw(magic bits endian vertype osabi verabi)} = unpack 'a4C5', $header; + + return unless $elf{magic} eq "\x7fELF"; + return unless $elf{vertype} == EV_CURRENT; + + my %abi; + my ($elf_word, $elf_endian); + if ($elf{bits} == ELF_BITS_32) { + $abi{bits} = 32; + $elf_word = 'L'; + } elsif ($elf{bits} == ELF_BITS_64) { + $abi{bits} = 64; + $elf_word = 'Q'; + } else { + return; + } + if ($elf{endian} == ELF_ORDER_2LSB) { + $abi{endian} = 'l'; + $elf_endian = '<'; + } elsif ($elf{endian} == ELF_ORDER_2MSB) { + $abi{endian} = 'b'; + $elf_endian = '>'; + } else { + return; + } + + # Unpack the endianness and size dependent fields. + my $tmpl = "x16(S2Lx[${elf_word}3]L)${elf_endian}"; + @elf{qw(type mach version flags)} = unpack $tmpl, $header; + + # Canonicalize the machine ID. + $elf{mach} = $elf_mach_map{$elf{mach}} // $elf{mach}; + $abi{mach} = $elf_mach_name{$elf{mach}} // $elf{mach}; + + # Mask any processor flags that might not change the architecture ABI. + $abi{flags} = $elf{flags} & ($elf_flags_mask{$elf{mach}} // 0); + + # Normalize into a colon-separated string for easy comparison, and easy + # debugging aid. + $format{$file} = join ':', 'ELF', @abi{qw(bits endian mach flags)}; + + return $format{$file}; +} + +sub is_elf { + my $file = shift; + open(my $file_fh, '<', $file) or syserr(g_('cannot read %s'), $file); + my ($header, $result) = ('', 0); + if (read($file_fh, $header, 4) == 4) { + $result = 1 if ($header =~ /^\177ELF$/); + } + close($file_fh); + return $result; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Shlibs/Objdump/Object.pm b/scripts/Dpkg/Shlibs/Objdump/Object.pm new file mode 100644 index 0000000..606ac05 --- /dev/null +++ b/scripts/Dpkg/Shlibs/Objdump/Object.pm @@ -0,0 +1,378 @@ +# Copyright © 2007-2010 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2007-2009,2012-2015,2017-2018 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Shlibs::Objdump::Object - represent an object from objdump output + +=head1 DESCRIPTION + +This module provides a class to represent an object parsed from +L<objdump(1)> output. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Shlibs::Objdump::Object 0.01; + +use strict; +use warnings; +use feature qw(state); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Path qw(find_command); +use Dpkg::Arch qw(debarch_to_gnutriplet get_build_arch get_host_arch); + +sub new { + my $this = shift; + my $file = shift // ''; + my $class = ref($this) || $this; + my $self = {}; + bless $self, $class; + + $self->reset; + if ($file) { + $self->analyze($file); + } + + return $self; +} + +sub reset { + my $self = shift; + + $self->{file} = ''; + $self->{id} = ''; + $self->{HASH} = ''; + $self->{GNU_HASH} = ''; + $self->{INTERP} = 0; + $self->{SONAME} = ''; + $self->{NEEDED} = []; + $self->{RPATH} = []; + $self->{dynsyms} = {}; + $self->{flags} = {}; + $self->{dynrelocs} = {}; + + return $self; +} + +sub _select_objdump { + # Decide which objdump to call + if (get_build_arch() ne get_host_arch()) { + my $od = debarch_to_gnutriplet(get_host_arch()) . '-objdump'; + return $od if find_command($od); + } + return 'objdump'; +} + +sub analyze { + my ($self, $file) = @_; + + $file ||= $self->{file}; + return unless $file; + + $self->reset; + $self->{file} = $file; + + $self->{exec_abi} = Dpkg::Shlibs::Objdump::get_format($file); + + if (not defined $self->{exec_abi}) { + warning(g_("unknown executable format in file '%s'"), $file); + return; + } + + state $OBJDUMP = _select_objdump(); + local $ENV{LC_ALL} = 'C'; + open(my $objdump, '-|', $OBJDUMP, '-w', '-f', '-p', '-T', '-R', $file) + or syserr(g_('cannot fork for %s'), $OBJDUMP); + my $ret = $self->parse_objdump_output($objdump); + close($objdump); + return $ret; +} + +sub parse_objdump_output { + my ($self, $fh) = @_; + + my $section = 'none'; + while (<$fh>) { + s/\s*$//; + next if length == 0; + + if (/^DYNAMIC SYMBOL TABLE:/) { + $section = 'dynsym'; + next; + } elsif (/^DYNAMIC RELOCATION RECORDS/) { + $section = 'dynreloc'; + $_ = <$fh>; # Skip header + next; + } elsif (/^Dynamic Section:/) { + $section = 'dyninfo'; + next; + } elsif (/^Program Header:/) { + $section = 'program'; + next; + } elsif (/^Version definitions:/) { + $section = 'verdef'; + next; + } elsif (/^Version References:/) { + $section = 'verref'; + next; + } + + if ($section eq 'dynsym') { + $self->parse_dynamic_symbol($_); + } elsif ($section eq 'dynreloc') { + if (/^\S+\s+(\S+)\s+(.+)$/) { + $self->{dynrelocs}{$2} = $1; + } else { + warning(g_("couldn't parse dynamic relocation record: %s"), $_); + } + } elsif ($section eq 'dyninfo') { + if (/^\s*NEEDED\s+(\S+)/) { + push @{$self->{NEEDED}}, $1; + } elsif (/^\s*SONAME\s+(\S+)/) { + $self->{SONAME} = $1; + } elsif (/^\s*HASH\s+(\S+)/) { + $self->{HASH} = $1; + } elsif (/^\s*GNU_HASH\s+(\S+)/) { + $self->{GNU_HASH} = $1; + } elsif (/^\s*RUNPATH\s+(\S+)/) { + # RUNPATH takes precedence over RPATH but is + # considered after LD_LIBRARY_PATH while RPATH + # is considered before (if RUNPATH is not set). + my $runpath = $1; + $self->{RPATH} = [ split /:/, $runpath ]; + } elsif (/^\s*RPATH\s+(\S+)/) { + my $rpath = $1; + unless (scalar(@{$self->{RPATH}})) { + $self->{RPATH} = [ split /:/, $rpath ]; + } + } + } elsif ($section eq 'program') { + if (/^\s*INTERP\s+/) { + $self->{INTERP} = 1; + } + } elsif ($section eq 'none') { + if (/^\s*.+:\s*file\s+format\s+(\S+)$/) { + $self->{format} = $1; + } elsif (/^architecture:\s*\S+,\s*flags\s*\S+:$/) { + # Parse 2 lines of "-f" + # architecture: i386, flags 0x00000112: + # EXEC_P, HAS_SYMS, D_PAGED + # start address 0x08049b50 + $_ = <$fh>; + chomp; + $self->{flags}{$_} = 1 foreach (split(/,\s*/)); + } + } + } + # Update status of dynamic symbols given the relocations that have + # been parsed after the symbols... + $self->apply_relocations(); + + return $section ne 'none'; +} + +# Output format of objdump -w -T +# +# /lib/libc.so.6: file format elf32-i386 +# +# DYNAMIC SYMBOL TABLE: +# 00056ef0 g DF .text 000000db GLIBC_2.2 getwchar +# 00000000 g DO *ABS* 00000000 GCC_3.0 GCC_3.0 +# 00069960 w DF .text 0000001e GLIBC_2.0 bcmp +# 00000000 w D *UND* 00000000 _pthread_cleanup_pop_restore +# 0000b788 g DF .text 0000008e Base .protected xine_close +# 0000b788 g DF .text 0000008e .hidden IA__g_free +# | ||||||| | | | | +# | ||||||| | | Version str (.visibility) + Symbol name +# | ||||||| | Alignment +# | ||||||| Section name (or *UND* for an undefined symbol) +# | ||||||F=Function,f=file,O=object +# | |||||d=debugging,D=dynamic +# | ||||I=Indirect +# | |||W=warning +# | ||C=constructor +# | |w=weak +# | g=global,l=local,!=both global/local +# Size of the symbol +# +# GLIBC_2.2 is the version string associated to the symbol +# (GLIBC_2.2) is the same but the symbol is hidden, a newer version of the +# symbol exist + +my $vis_re = qr/(\.protected|\.hidden|\.internal|0x\S+)/; +my $dynsym_re = qr< + ^ + [0-9a-f]+ # Symbol size + \ (.{7}) # Flags + \s+(\S+) # Section name + \s+[0-9a-f]+ # Alignment + (?:\s+(\S+))? # Version string + (?:\s+$vis_re)? # Visibility + \s+(.+) # Symbol name +>x; + +sub parse_dynamic_symbol { + my ($self, $line) = @_; + if ($line =~ $dynsym_re) { + my ($flags, $sect, $ver, $vis, $name) = ($1, $2, $3, $4, $5); + + # Special case if version is missing but extra visibility + # attribute replaces it in the match + if (defined($ver) and $ver =~ /^$vis_re$/) { + $vis = $ver; + $ver = ''; + } + + # Cleanup visibility field + $vis =~ s/^\.// if defined($vis); + + my $symbol = { + name => $name, + version => $ver // '', + section => $sect, + dynamic => substr($flags, 5, 1) eq 'D', + debug => substr($flags, 5, 1) eq 'd', + type => substr($flags, 6, 1), + weak => substr($flags, 1, 1) eq 'w', + local => substr($flags, 0, 1) eq 'l', + global => substr($flags, 0, 1) eq 'g', + visibility => $vis // '', + hidden => '', + defined => $sect ne '*UND*' + }; + + # Handle hidden symbols + if (defined($ver) and $ver =~ /^\((.*)\)$/) { + $ver = $1; + $symbol->{version} = $1; + $symbol->{hidden} = 1; + } + + # Register symbol + $self->add_dynamic_symbol($symbol); + } elsif ($line =~ /^[0-9a-f]+ (.{7})\s+(\S+)\s+[0-9a-f]+/) { + # Same start but no version and no symbol ... just ignore + } elsif ($line =~ /^REG_G\d+\s+/) { + # Ignore some s390-specific output like + # REG_G6 g R *UND* 0000000000000000 #scratch + } else { + warning(g_("couldn't parse dynamic symbol definition: %s"), $line); + } +} + +sub apply_relocations { + my $self = shift; + foreach my $sym (values %{$self->{dynsyms}}) { + # We want to mark as undefined symbols those which are currently + # defined but that depend on a copy relocation + next if not $sym->{defined}; + + my @relocs; + + # When objdump qualifies the symbol with a version it will use @ when + # the symbol is in an undefined section (which we discarded above, or + # @@ otherwise. + push @relocs, $sym->{name} . '@@' . $sym->{version} if $sym->{version}; + + # Symbols that are not versioned, or versioned but shown with objdump + # from binutils < 2.26, do not have a version appended. + push @relocs, $sym->{name}; + + foreach my $reloc (@relocs) { + next if not exists $self->{dynrelocs}{$reloc}; + next if not $self->{dynrelocs}{$reloc} =~ /^R_.*_COPY$/; + + $sym->{defined} = 0; + last; + } + } +} + +sub add_dynamic_symbol { + my ($self, $symbol) = @_; + $symbol->{objid} = $symbol->{soname} = $self->get_id(); + $symbol->{soname} =~ s{^.*/}{} unless $self->{SONAME}; + if ($symbol->{version}) { + $self->{dynsyms}{$symbol->{name} . '@' . $symbol->{version}} = $symbol; + } else { + $self->{dynsyms}{$symbol->{name} . '@Base'} = $symbol; + } +} + +sub get_id { + my $self = shift; + return $self->{SONAME} || $self->{file}; +} + +sub get_symbol { + my ($self, $name) = @_; + if (exists $self->{dynsyms}{$name}) { + return $self->{dynsyms}{$name}; + } + if ($name !~ /@/) { + if (exists $self->{dynsyms}{$name . '@Base'}) { + return $self->{dynsyms}{$name . '@Base'}; + } + } + return; +} + +sub get_exported_dynamic_symbols { + my $self = shift; + return grep { + $_->{defined} && $_->{dynamic} && !$_->{local} + } values %{$self->{dynsyms}}; +} + +sub get_undefined_dynamic_symbols { + my $self = shift; + return grep { + (!$_->{defined}) && $_->{dynamic} + } values %{$self->{dynsyms}}; +} + +sub get_needed_libraries { + my $self = shift; + return @{$self->{NEEDED}}; +} + +sub is_executable { + my $self = shift; + return (exists $self->{flags}{EXEC_P} && $self->{flags}{EXEC_P}) || + (exists $self->{INTERP} && $self->{INTERP}); +} + +sub is_public_library { + my $self = shift; + return exists $self->{flags}{DYNAMIC} && $self->{flags}{DYNAMIC} + && exists $self->{SONAME} && $self->{SONAME}; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Shlibs/Symbol.pm b/scripts/Dpkg/Shlibs/Symbol.pm new file mode 100644 index 0000000..f4955bb --- /dev/null +++ b/scripts/Dpkg/Shlibs/Symbol.pm @@ -0,0 +1,548 @@ +# Copyright © 2007 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2009-2010 Modestas Vainius <modax@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Shlibs::Symbol - represent an object file symbol + +=head1 DESCRIPTION + +This module provides a class to handle symbols from an executable or +shared object file. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Shlibs::Symbol 0.01; + +use strict; +use warnings; + +use Storable (); +use List::Util qw(any); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Arch qw(debarch_is_concerned debarch_to_abiattrs); +use Dpkg::Version; +use Dpkg::Shlibs::Cppfilt; + +# Supported alias types in the order of matching preference +use constant ALIAS_TYPES => qw( + c++ + symver +); + +sub new { + my ($this, %args) = @_; + my $class = ref($this) || $this; + my $self = bless { + symbol => undef, + symbol_templ => undef, + minver => undef, + dep_id => 0, + deprecated => 0, + tags => {}, + tagorder => [], + }, $class; + $self->{$_} = $args{$_} foreach keys %args; + return $self; +} + +# Deep clone +sub clone { + my ($self, %args) = @_; + my $clone = Storable::dclone($self); + $clone->{$_} = $args{$_} foreach keys %args; + return $clone; +} + +sub parse_tagspec { + my ($self, $tagspec) = @_; + + if ($tagspec =~ /^\s*\((.*?)\)(.*)$/ && $1) { + # (tag1=t1 value|tag2|...|tagN=tNp) + # Symbols ()|= cannot appear in the tag names and values + $tagspec = $1; + my $rest = ($2) ? $2 : ''; + my @tags = split(/\|/, $tagspec); + + # Parse each tag + for my $tag (@tags) { + if ($tag =~ /^(.*)=(.*)$/) { + # Tag with value + $self->add_tag($1, $2); + } else { + # Tag without value + $self->add_tag($tag, undef); + } + } + return $rest; + } + return; +} + +sub parse_symbolspec { + my ($self, $symbolspec, %opts) = @_; + my $symbol; + my $symbol_templ; + my $symbol_quoted; + my $rest; + + if (defined($symbol = $self->parse_tagspec($symbolspec))) { + # (tag1=t1 value|tag2|...|tagN=tNp)"Foo::Bar::foobar()"@Base 1.0 1 + # Symbols ()|= cannot appear in the tag names and values + + # If the tag specification exists symbol name template might be quoted too + if ($symbol =~ /^(['"])/ && $symbol =~ /^($1)(.*?)$1(.*)$/) { + $symbol_quoted = $1; + $symbol_templ = $2; + $symbol = $2; + $rest = $3; + } else { + if ($symbol =~ m/^(\S+)(.*)$/) { + $symbol_templ = $1; + $symbol = $1; + $rest = $2; + } + } + error(g_('symbol name unspecified: %s'), $symbolspec) if (!$symbol); + } else { + # No tag specification. Symbol name is up to the first space + # foobarsymbol@Base 1.0 1 + if ($symbolspec =~ m/^(\S+)(.*)$/) { + $symbol = $1; + $rest = $2; + } else { + return 0; + } + } + $self->{symbol} = $symbol; + $self->{symbol_templ} = $symbol_templ; + $self->{symbol_quoted} = $symbol_quoted if ($symbol_quoted); + + # Now parse "the rest" (minver and dep_id) + if ($rest =~ /^\s(\S+)(?:\s(\d+))?/) { + $self->{minver} = $1; + $self->{dep_id} = $2 // 0; + } elsif (defined $opts{default_minver}) { + $self->{minver} = $opts{default_minver}; + $self->{dep_id} = 0; + } else { + return 0; + } + return 1; +} + +# A hook for symbol initialization (typically processing of tags). The code +# here may even change symbol name. Called from +# Dpkg::Shlibs::SymbolFile::create_symbol(). +sub initialize { + my $self = shift; + + # Look for tags marking symbol patterns. The pattern may match multiple + # real symbols. + my $type; + if ($self->has_tag('c++')) { + # Raw symbol name is always demangled to the same alias while demangled + # symbol name cannot be reliably converted back to raw symbol name. + # Therefore, we can use hash for mapping. + $type = 'alias-c++'; + } + + # Support old style wildcard syntax. That's basically a symver + # with an optional tag. + if ($self->get_symbolname() =~ /^\*@(.*)$/) { + $self->add_tag('symver') unless $self->has_tag('symver'); + $self->add_tag('optional') unless $self->has_tag('optional'); + $self->{symbol} = $1; + } + + if ($self->has_tag('symver')) { + # Each symbol is matched against its version rather than full + # name@version string. + $type = (defined $type) ? 'generic' : 'alias-symver'; + if ($self->get_symbolname() =~ /@/) { + warning(g_('symver tag with versioned symbol will not match: %s'), + $self->get_symbolspec(1)); + } + if ($self->get_symbolname() eq 'Base') { + error(g_("you can't use symver tag to catch unversioned symbols: %s"), + $self->get_symbolspec(1)); + } + } + + # As soon as regex is involved, we need to match each real + # symbol against each pattern (aka 'generic' pattern). + if ($self->has_tag('regex')) { + $type = 'generic'; + # Pre-compile regular expression for better performance. + my $regex = $self->get_symbolname(); + $self->{pattern}{regex} = qr/$regex/; + } + if (defined $type) { + $self->init_pattern($type); + } +} + +sub get_symbolname { + my $self = shift; + + return $self->{symbol}; +} + +sub get_symboltempl { + my $self = shift; + + return $self->{symbol_templ} || $self->{symbol}; +} + +sub set_symbolname { + my ($self, $name, $templ, $quoted) = @_; + + $name //= $self->{symbol}; + if (!defined $templ && $name =~ /\s/) { + $templ = $name; + } + if (!defined $quoted && defined $templ && $templ =~ /\s/) { + $quoted = '"'; + } + $self->{symbol} = $name; + $self->{symbol_templ} = $templ; + if ($quoted) { + $self->{symbol_quoted} = $quoted; + } else { + delete $self->{symbol_quoted}; + } +} + +sub has_tags { + my $self = shift; + return scalar (@{$self->{tagorder}}); +} + +sub add_tag { + my ($self, $tagname, $tagval) = @_; + if (exists $self->{tags}{$tagname}) { + $self->{tags}{$tagname} = $tagval; + return 0; + } else { + $self->{tags}{$tagname} = $tagval; + push @{$self->{tagorder}}, $tagname; + } + return 1; +} + +sub delete_tag { + my ($self, $tagname) = @_; + if (exists $self->{tags}{$tagname}) { + delete $self->{tags}{$tagname}; + $self->{tagorder} = [ grep { $_ ne $tagname } @{$self->{tagorder}} ]; + return 1; + } + return 0; +} + +sub has_tag { + my ($self, $tag) = @_; + return exists $self->{tags}{$tag}; +} + +sub get_tag_value { + my ($self, $tag) = @_; + return $self->{tags}{$tag}; +} + +# Checks if the symbol is equal to another one (by name and optionally, +# tag sets, versioning info (minver and depid)) +sub equals { + my ($self, $other, %opts) = @_; + $opts{versioning} //= 1; + $opts{tags} //= 1; + + return 0 if $self->{symbol} ne $other->{symbol}; + + if ($opts{versioning}) { + return 0 if $self->{minver} ne $other->{minver}; + return 0 if $self->{dep_id} ne $other->{dep_id}; + } + + if ($opts{tags}) { + return 0 if scalar(@{$self->{tagorder}}) != scalar(@{$other->{tagorder}}); + + for my $i (0 .. scalar(@{$self->{tagorder}}) - 1) { + my $tag = $self->{tagorder}->[$i]; + return 0 if $tag ne $other->{tagorder}->[$i]; + if (defined $self->{tags}{$tag} && defined $other->{tags}{$tag}) { + return 0 if $self->{tags}{$tag} ne $other->{tags}{$tag}; + } elsif (defined $self->{tags}{$tag} || defined $other->{tags}{$tag}) { + return 0; + } + } + } + + return 1; +} + + +sub is_optional { + my $self = shift; + return $self->has_tag('optional'); +} + +sub is_arch_specific { + my $self = shift; + return $self->has_tag('arch'); +} + +sub arch_is_concerned { + my ($self, $arch) = @_; + my $arches = $self->{tags}{arch}; + + return 0 if defined $arch && defined $arches && + !debarch_is_concerned($arch, split /[\s,]+/, $arches); + + my ($bits, $endian) = debarch_to_abiattrs($arch); + return 0 if defined $bits && defined $self->{tags}{'arch-bits'} && + $bits ne $self->{tags}{'arch-bits'}; + return 0 if defined $endian && defined $self->{tags}{'arch-endian'} && + $endian ne $self->{tags}{'arch-endian'}; + + return 1; +} + +# Get reference to the pattern the symbol matches (if any) +sub get_pattern { + my $self = shift; + + return $self->{matching_pattern}; +} + +### NOTE: subroutines below require (or initialize) $self to be a pattern ### + +# Initializes this symbol as a pattern of the specified type. +sub init_pattern { + my ($self, $type) = @_; + + $self->{pattern}{type} = $type; + # To be filled with references to symbols matching this pattern. + $self->{pattern}{matches} = []; +} + +# Is this symbol a pattern or not? +sub is_pattern { + my $self = shift; + + return exists $self->{pattern}; +} + +# Get pattern type if this symbol is a pattern. +sub get_pattern_type { + my $self = shift; + + return $self->{pattern}{type} // ''; +} + +# Get (sub)type of the alias pattern. Returns empty string if current +# pattern is not alias. +sub get_alias_type { + my $self = shift; + + return ($self->get_pattern_type() =~ /^alias-(.+)/ && $1) || ''; +} + +# Get a list of symbols matching this pattern if this symbol is a pattern +sub get_pattern_matches { + my $self = shift; + + return @{$self->{pattern}{matches}}; +} + +# Create a new symbol based on the pattern (i.e. $self) +# and add it to the pattern matches list. +sub create_pattern_match { + my $self = shift; + return unless $self->is_pattern(); + + # Leave out 'pattern' subfield while deep-cloning + my $pattern_stuff = $self->{pattern}; + delete $self->{pattern}; + my $newsym = $self->clone(@_); + $self->{pattern} = $pattern_stuff; + + # Clean up symbol name related internal fields + $newsym->set_symbolname(); + + # Set newsym pattern reference, add to pattern matches list + $newsym->{matching_pattern} = $self; + push @{$self->{pattern}{matches}}, $newsym; + return $newsym; +} + +### END of pattern subroutines ### + +# Given a raw symbol name the call returns its alias according to the rules of +# the current pattern ($self). Returns undef if the supplied raw name is not +# transformable to alias. +sub convert_to_alias { + my ($self, $rawname, $type) = @_; + $type = $self->get_alias_type() unless $type; + + if ($type) { + if ($type eq 'symver') { + # In case of symver, alias is symbol version. Extract it from the + # rawname. + return "$1" if ($rawname =~ /\@([^@]+)$/); + } elsif ($rawname =~ /^_Z/ && $type eq 'c++') { + return cppfilt_demangle_cpp($rawname); + } + } + return; +} + +sub get_tagspec { + my $self = shift; + if ($self->has_tags()) { + my @tags; + for my $tagname (@{$self->{tagorder}}) { + my $tagval = $self->{tags}{$tagname}; + if (defined $tagval) { + push @tags, $tagname . '=' . $tagval; + } else { + push @tags, $tagname; + } + } + return '(' . join('|', @tags) . ')'; + } + return ''; +} + +sub get_symbolspec { + my $self = shift; + my $template_mode = shift; + my $spec = ''; + $spec .= "#MISSING: $self->{deprecated}#" if $self->{deprecated}; + $spec .= ' '; + if ($template_mode) { + if ($self->has_tags()) { + $spec .= sprintf('%s%3$s%s%3$s', $self->get_tagspec(), + $self->get_symboltempl(), $self->{symbol_quoted} // ''); + } else { + $spec .= $self->get_symboltempl(); + } + } else { + $spec .= $self->get_symbolname(); + } + $spec .= " $self->{minver}"; + $spec .= " $self->{dep_id}" if $self->{dep_id}; + return $spec; +} + +# Sanitize the symbol when it is confirmed to be found in +# the respective library. +sub mark_found_in_library { + my ($self, $minver, $arch) = @_; + + if ($self->{deprecated}) { + # Symbol reappeared somehow + $self->{deprecated} = 0; + $self->{minver} = $minver if (not $self->is_optional()); + } else { + # We assume that the right dependency information is already + # there. + if (version_compare($minver, $self->{minver}) < 0) { + $self->{minver} = $minver; + } + } + # Never remove arch tags from patterns + if (not $self->is_pattern()) { + if (not $self->arch_is_concerned($arch)) { + # Remove arch tags because they are incorrect. + $self->delete_tag('arch'); + $self->delete_tag('arch-bits'); + $self->delete_tag('arch-endian'); + } + } +} + +# Sanitize the symbol when it is confirmed to be NOT found in +# the respective library. +# Mark as deprecated those that are no more provided (only if the +# minver is later than the version where the symbol was introduced) +sub mark_not_found_in_library { + my ($self, $minver, $arch) = @_; + + # Ignore symbols from foreign arch + return if not $self->arch_is_concerned($arch); + + if ($self->{deprecated}) { + # Bump deprecated if the symbol is optional so that it + # keeps reappearing in the diff while it's missing + $self->{deprecated} = $minver if $self->is_optional(); + } elsif (version_compare($minver, $self->{minver}) > 0) { + $self->{deprecated} = $minver; + } +} + +# Checks if the symbol (or pattern) is legitimate as a real symbol for the +# specified architecture. +sub is_legitimate { + my ($self, $arch) = @_; + return ! $self->{deprecated} && + $self->arch_is_concerned($arch); +} + +# Determine whether a supplied raw symbol name matches against current ($self) +# symbol or pattern. +sub matches_rawname { + my ($self, $rawname) = @_; + my $target = $rawname; + my $ok = 1; + my $do_eq_match = 1; + + if ($self->is_pattern()) { + # Process pattern tags in the order they were specified. + for my $tag (@{$self->{tagorder}}) { + if (any { $tag eq $_ } ALIAS_TYPES) { + $ok = not not ($target = $self->convert_to_alias($target, $tag)); + } elsif ($tag eq 'regex') { + # Symbol name is a regex. Match it against the target + $do_eq_match = 0; + $ok = ($target =~ $self->{pattern}{regex}); + } + last if not $ok; + } + } + + # Equality match by default + if ($ok && $do_eq_match) { + $ok = $target eq $self->get_symbolname(); + } + return $ok; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Shlibs/SymbolFile.pm b/scripts/Dpkg/Shlibs/SymbolFile.pm new file mode 100644 index 0000000..61c783a --- /dev/null +++ b/scripts/Dpkg/Shlibs/SymbolFile.pm @@ -0,0 +1,713 @@ +# Copyright © 2007 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2009-2010 Modestas Vainius <modax@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Shlibs::SymbolFile - represent a symbols file + +=head1 DESCRIPTION + +This module provides a class to handle symbols files. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Shlibs::SymbolFile 0.01; + +use strict; +use warnings; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Version; +use Dpkg::Control::Fields; +use Dpkg::Shlibs::Symbol; +use Dpkg::Arch qw(get_host_arch); + +use parent qw(Dpkg::Interface::Storable); + +my %internal_symbol = ( + __bss_end__ => 1, # arm + __bss_end => 1, # arm + _bss_end__ => 1, # arm + __bss_start => 1, # ALL + __bss_start__ => 1, # arm + __data_start => 1, # arm + __do_global_ctors_aux => 1, # ia64 + __do_global_dtors_aux => 1, # ia64 + __do_jv_register_classes => 1, # ia64 + _DYNAMIC => 1, # ALL + _edata => 1, # ALL + _end => 1, # ALL + __end__ => 1, # arm + __exidx_end => 1, # armel + __exidx_start => 1, # armel + _fbss => 1, # mips, mipsel + _fdata => 1, # mips, mipsel + _fini => 1, # ALL + _ftext => 1, # mips, mipsel + _GLOBAL_OFFSET_TABLE_ => 1, # hppa, mips, mipsel + __gmon_start__ => 1, # hppa + __gnu_local_gp => 1, # mips, mipsel + _gp => 1, # mips, mipsel + _init => 1, # ALL + _PROCEDURE_LINKAGE_TABLE_ => 1, # sparc, alpha + _SDA2_BASE_ => 1, # powerpc + _SDA_BASE_ => 1, # powerpc +); + +for my $i (14 .. 31) { + # Many powerpc specific symbols + $internal_symbol{"_restfpr_$i"} = 1; + $internal_symbol{"_restfpr_$i\_x"} = 1; + $internal_symbol{"_restgpr_$i"} = 1; + $internal_symbol{"_restgpr_$i\_x"} = 1; + $internal_symbol{"_savefpr_$i"} = 1; + $internal_symbol{"_savegpr_$i"} = 1; +} + +sub symbol_is_internal { + my ($symbol, $include_groups) = @_; + + return 1 if exists $internal_symbol{$symbol}; + + # The ARM Embedded ABI spec states symbols under this namespace as + # possibly appearing in output objects. + return 1 if not ${$include_groups}{aeabi} and $symbol =~ /^__aeabi_/; + + # The GNU implementation of the OpenMP spec, specifies symbols under + # this namespace as possibly appearing in output objects. + return 1 if not ${$include_groups}{gomp} + and $symbol =~ /^\.gomp_critical_user_/; + + return 0; +} + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + my $self = \%opts; + bless $self, $class; + $self->{arch} //= get_host_arch(); + $self->clear(); + if (exists $self->{file}) { + $self->load($self->{file}) if -e $self->{file}; + } + return $self; +} + +sub get_arch { + my $self = shift; + return $self->{arch}; +} + +sub clear { + my $self = shift; + $self->{objects} = {}; +} + +sub clear_except { + my ($self, @ids) = @_; + + my %has = map { $_ => 1 } @ids; + foreach my $objid (keys %{$self->{objects}}) { + delete $self->{objects}{$objid} unless exists $has{$objid}; + } +} + +sub get_sonames { + my $self = shift; + return keys %{$self->{objects}}; +} + +sub get_symbols { + my ($self, $soname) = @_; + if (defined $soname) { + my $obj = $self->get_object($soname); + return (defined $obj) ? values %{$obj->{syms}} : (); + } else { + my @syms; + foreach my $soname ($self->get_sonames()) { + push @syms, $self->get_symbols($soname); + } + return @syms; + } +} + +sub get_patterns { + my ($self, $soname) = @_; + my @patterns; + if (defined $soname) { + my $obj = $self->get_object($soname); + foreach my $alias (values %{$obj->{patterns}{aliases}}) { + push @patterns, values %$alias; + } + return (@patterns, @{$obj->{patterns}{generic}}); + } else { + foreach my $soname ($self->get_sonames()) { + push @patterns, $self->get_patterns($soname); + } + return @patterns; + } +} + +# Create a symbol from the supplied string specification. +sub create_symbol { + my ($self, $spec, %opts) = @_; + my $symbol = (exists $opts{base}) ? $opts{base} : + Dpkg::Shlibs::Symbol->new(); + + my $ret = $opts{dummy} ? $symbol->parse_symbolspec($spec, default_minver => 0) : + $symbol->parse_symbolspec($spec); + if ($ret) { + $symbol->initialize(arch => $self->get_arch()); + return $symbol; + } + return; +} + +sub add_symbol { + my ($self, $symbol, $soname) = @_; + my $object = $self->get_object($soname); + + if ($symbol->is_pattern()) { + if (my $alias_type = $symbol->get_alias_type()) { + $object->{patterns}{aliases}{$alias_type} //= {}; + # Alias hash for matching. + my $aliases = $object->{patterns}{aliases}{$alias_type}; + $aliases->{$symbol->get_symbolname()} = $symbol; + } else { + # Otherwise assume this is a generic sequential pattern. This + # should be always safe. + push @{$object->{patterns}{generic}}, $symbol; + } + return 'pattern'; + } else { + # invalidate the minimum version cache + $object->{minver_cache} = []; + $object->{syms}{$symbol->get_symbolname()} = $symbol; + return 'sym'; + } +} + +sub _new_symbol { + my $base = shift || 'Dpkg::Shlibs::Symbol'; + return (ref $base) ? $base->clone(@_) : $base->new(@_); +} + +# Option state is only used for recursive calls. +sub parse { + my ($self, $fh, $file, %opts) = @_; + my $state = $opts{state} //= {}; + + if (exists $state->{seen}) { + return if exists $state->{seen}{$file}; # Avoid include loops + } else { + $self->{file} = $file; + $state->{seen} = {}; + } + $state->{seen}{$file} = 1; + + if (not ref $state->{obj_ref}) { # Init ref to name of current object/lib + ${$state->{obj_ref}} = undef; + } + + while (<$fh>) { + chomp; + + if (/^(?:\s+|#(?:DEPRECATED|MISSING): ([^#]+)#\s*)(.*)/) { + if (not defined ${$state->{obj_ref}}) { + error(g_('symbol information must be preceded by a header (file %s, line %s)'), $file, $.); + } + # Symbol specification + my $deprecated = ($1) ? Dpkg::Version->new($1) : 0; + my $sym = _new_symbol($state->{base_symbol}, deprecated => $deprecated); + if ($self->create_symbol($2, base => $sym)) { + $self->add_symbol($sym, ${$state->{obj_ref}}); + } else { + warning(g_('failed to parse line in %s: %s'), $file, $_); + } + } elsif (/^(\(.*\))?#include\s+"([^"]+)"/) { + my $tagspec = $1; + my $filename = $2; + my $dir = $file; + my $old_base_symbol = $state->{base_symbol}; + my $new_base_symbol; + if (defined $tagspec) { + $new_base_symbol = _new_symbol($old_base_symbol); + $new_base_symbol->parse_tagspec($tagspec); + } + $state->{base_symbol} = $new_base_symbol; + $dir =~ s{[^/]+$}{}; # Strip filename + $self->load("$dir$filename", %opts); + $state->{base_symbol} = $old_base_symbol; + } elsif (/^#|^$/) { + # Skip possible comments and empty lines + } elsif (/^\|\s*(.*)$/) { + # Alternative dependency template + push @{$self->{objects}{${$state->{obj_ref}}}{deps}}, "$1"; + } elsif (/^\*\s*([^:]+):\s*(.*\S)\s*$/) { + # Add meta-fields + $self->{objects}{${$state->{obj_ref}}}{fields}{field_capitalize($1)} = $2; + } elsif (/^(\S+)\s+(.*)$/) { + # New object and dependency template + ${$state->{obj_ref}} = $1; + if (exists $self->{objects}{${$state->{obj_ref}}}) { + # Update/override infos only + $self->{objects}{${$state->{obj_ref}}}{deps} = [ "$2" ]; + } else { + # Create a new object + $self->create_object(${$state->{obj_ref}}, "$2"); + } + } else { + warning(g_('failed to parse a line in %s: %s'), $file, $_); + } + } + delete $state->{seen}{$file}; +} + +# Beware: we reuse the data structure of the provided symfile so make +# sure to not modify them after having called this function +sub merge_object_from_symfile { + my ($self, $src, $objid) = @_; + if (not $self->has_object($objid)) { + $self->{objects}{$objid} = $src->get_object($objid); + } else { + warning(g_('tried to merge the same object (%s) twice in a symfile'), $objid); + } +} + +sub output { + my ($self, $fh, %opts) = @_; + $opts{template_mode} //= 0; + $opts{with_deprecated} //= 1; + $opts{with_pattern_matches} //= 0; + my $res = ''; + foreach my $soname (sort $self->get_sonames()) { + my @deps = $self->get_dependencies($soname); + my $dep_first = shift @deps; + if (exists $opts{package} and not $opts{template_mode}) { + $dep_first =~ s/#PACKAGE#/$opts{package}/g; + } + print { $fh } "$soname $dep_first\n" if defined $fh; + $res .= "$soname $dep_first\n" if defined wantarray; + + foreach my $dep_next (@deps) { + if (exists $opts{package} and not $opts{template_mode}) { + $dep_next =~ s/#PACKAGE#/$opts{package}/g; + } + print { $fh } "| $dep_next\n" if defined $fh; + $res .= "| $dep_next\n" if defined wantarray; + } + my $f = $self->{objects}{$soname}{fields}; + foreach my $field (sort keys %{$f}) { + my $value = $f->{$field}; + if (exists $opts{package} and not $opts{template_mode}) { + $value =~ s/#PACKAGE#/$opts{package}/g; + } + print { $fh } "* $field: $value\n" if defined $fh; + $res .= "* $field: $value\n" if defined wantarray; + } + + my @symbols; + if ($opts{template_mode}) { + # Exclude symbols matching a pattern, but include patterns themselves + @symbols = grep { not $_->get_pattern() } $self->get_symbols($soname); + push @symbols, $self->get_patterns($soname); + } else { + @symbols = $self->get_symbols($soname); + } + foreach my $sym (sort { $a->get_symboltempl() cmp + $b->get_symboltempl() } @symbols) { + next if $sym->{deprecated} and not $opts{with_deprecated}; + # Do not dump symbols from foreign arch unless dumping a template. + next if not $opts{template_mode} and + not $sym->arch_is_concerned($self->get_arch()); + # Dump symbol specification. Dump symbol tags only in template mode. + print { $fh } $sym->get_symbolspec($opts{template_mode}), "\n" if defined $fh; + $res .= $sym->get_symbolspec($opts{template_mode}) . "\n" if defined wantarray; + # Dump pattern matches as comments (if requested) + if ($opts{with_pattern_matches} && $sym->is_pattern()) { + for my $match (sort { $a->get_symboltempl() cmp + $b->get_symboltempl() } $sym->get_pattern_matches()) + { + print { $fh } '#MATCH:', $match->get_symbolspec(0), "\n" if defined $fh; + $res .= '#MATCH:' . $match->get_symbolspec(0) . "\n" if defined wantarray; + } + } + } + } + return $res; +} + +# Tries to match a symbol name and/or version against the patterns defined. +# Returns a pattern which matches (if any). +sub find_matching_pattern { + my ($self, $refsym, $sonames, $inc_deprecated) = @_; + $inc_deprecated //= 0; + my $name = (ref $refsym) ? $refsym->get_symbolname() : $refsym; + + my $pattern_ok = sub { + my $p = shift; + return defined $p && ($inc_deprecated || !$p->{deprecated}) && + $p->arch_is_concerned($self->get_arch()); + }; + + foreach my $soname ((ref($sonames) eq 'ARRAY') ? @$sonames : $sonames) { + my $obj = $self->get_object($soname); + my ($type, $pattern); + next unless defined $obj; + + my $all_aliases = $obj->{patterns}{aliases}; + for my $type (Dpkg::Shlibs::Symbol::ALIAS_TYPES) { + if (exists $all_aliases->{$type} && keys(%{$all_aliases->{$type}})) { + my $aliases = $all_aliases->{$type}; + my $converter = $aliases->{(keys %$aliases)[0]}; + if (my $alias = $converter->convert_to_alias($name)) { + if ($alias && exists $aliases->{$alias}) { + $pattern = $aliases->{$alias}; + last if $pattern_ok->($pattern); + $pattern = undef; # otherwise not found yet + } + } + } + } + + # Now try generic patterns and use the first that matches + if (not defined $pattern) { + for my $p (@{$obj->{patterns}{generic}}) { + if ($pattern_ok->($p) && $p->matches_rawname($name)) { + $pattern = $p; + last; + } + } + } + if (defined $pattern) { + return (wantarray) ? + ( symbol => $pattern, soname => $soname ) : $pattern; + } + } + return; +} + +# merge_symbols($object, $minver) +# Needs $Objdump->get_object($soname) as parameter +# Do not merge symbols found in the list of (arch-specific) internal symbols. +sub merge_symbols { + my ($self, $object, $minver) = @_; + + my $soname = $object->{SONAME}; + error(g_('cannot merge symbols from objects without SONAME')) + unless $soname; + + my %include_groups = (); + my $groups = $self->get_field($soname, 'Allow-Internal-Symbol-Groups'); + if (not defined $groups) { + $groups = $self->get_field($soname, 'Ignore-Blacklist-Groups'); + if (defined $groups) { + warnings::warnif('deprecated', + 'symbols file field "Ignore-Blacklist-Groups" is deprecated, ' . + 'use "Allow-Internal-Symbol-Groups" instead'); + } + } + if (defined $groups) { + $include_groups{$_} = 1 foreach (split ' ', $groups); + } + + my %dynsyms; + foreach my $sym ($object->get_exported_dynamic_symbols()) { + my $name = $sym->{name} . '@' . + ($sym->{version} ? $sym->{version} : 'Base'); + my $symobj = $self->lookup_symbol($name, $soname); + if (symbol_is_internal($sym->{name}, \%include_groups)) { + next unless defined $symobj; + + if ($symobj->has_tag('allow-internal')) { + # Allow the symbol. + } elsif ($symobj->has_tag('ignore-blacklist')) { + # Allow the symbol and warn. + warnings::warnif('deprecated', + 'symbol tag "ignore-blacklist" is deprecated, ' . + 'use "allow-internal" instead'); + } else { + # Ignore the symbol. + next; + } + } + $dynsyms{$name} = $sym; + } + + unless ($self->has_object($soname)) { + $self->create_object($soname, ''); + } + # Scan all symbols provided by the objects + my $obj = $self->get_object($soname); + # invalidate the minimum version cache - it is not sufficient to + # invalidate in add_symbol, since we might change a minimum + # version for a particular symbol without adding it + $obj->{minver_cache} = []; + foreach my $name (keys %dynsyms) { + my $sym; + if ($sym = $self->lookup_symbol($name, $obj, 1)) { + # If the symbol is already listed in the file + $sym->mark_found_in_library($minver, $self->get_arch()); + } else { + # The exact symbol is not present in the file, but it might match a + # pattern. + my $pattern = $self->find_matching_pattern($name, $obj, 1); + if (defined $pattern) { + $pattern->mark_found_in_library($minver, $self->get_arch()); + $sym = $pattern->create_pattern_match(symbol => $name); + } else { + # Symbol without any special info as no pattern matched + $sym = Dpkg::Shlibs::Symbol->new(symbol => $name, + minver => $minver); + } + $self->add_symbol($sym, $obj); + } + } + + # Process all symbols which could not be found in the library. + foreach my $sym ($self->get_symbols($soname)) { + if (not exists $dynsyms{$sym->get_symbolname()}) { + $sym->mark_not_found_in_library($minver, $self->get_arch()); + } + } + + # Deprecate patterns which didn't match anything + for my $pattern (grep { $_->get_pattern_matches() == 0 } + $self->get_patterns($soname)) { + $pattern->mark_not_found_in_library($minver, $self->get_arch()); + } +} + +sub is_empty { + my $self = shift; + return scalar(keys %{$self->{objects}}) ? 0 : 1; +} + +sub has_object { + my ($self, $soname) = @_; + return exists $self->{objects}{$soname}; +} + +sub get_object { + my ($self, $soname) = @_; + return ref($soname) ? $soname : $self->{objects}{$soname}; +} + +sub create_object { + my ($self, $soname, @deps) = @_; + $self->{objects}{$soname} = { + syms => {}, + fields => {}, + patterns => { + aliases => {}, + generic => [], + }, + deps => [ @deps ], + minver_cache => [] + }; +} + +sub get_dependency { + my ($self, $soname, $dep_id) = @_; + $dep_id //= 0; + return $self->get_object($soname)->{deps}[$dep_id]; +} + +sub get_smallest_version { + my ($self, $soname, $dep_id) = @_; + $dep_id //= 0; + my $so_object = $self->get_object($soname); + return $so_object->{minver_cache}[$dep_id] + if defined $so_object->{minver_cache}[$dep_id]; + my $minver; + foreach my $sym ($self->get_symbols($so_object)) { + next if $dep_id != $sym->{dep_id}; + $minver //= $sym->{minver}; + if (version_compare($minver, $sym->{minver}) > 0) { + $minver = $sym->{minver}; + } + } + $so_object->{minver_cache}[$dep_id] = $minver; + return $minver; +} + +sub get_dependencies { + my ($self, $soname) = @_; + return @{$self->get_object($soname)->{deps}}; +} + +sub get_field { + my ($self, $soname, $name) = @_; + if (my $obj = $self->get_object($soname)) { + if (exists $obj->{fields}{$name}) { + return $obj->{fields}{$name}; + } + } + return; +} + +# Tries to find a symbol like the $refsym and returns its descriptor. +# $refsym may also be a symbol name. +sub lookup_symbol { + my ($self, $refsym, $sonames, $inc_deprecated) = @_; + $inc_deprecated //= 0; + my $name = (ref $refsym) ? $refsym->get_symbolname() : $refsym; + + foreach my $so ((ref($sonames) eq 'ARRAY') ? @$sonames : $sonames) { + if (my $obj = $self->get_object($so)) { + my $sym = $obj->{syms}{$name}; + if ($sym and ($inc_deprecated or not $sym->{deprecated})) + { + return (wantarray) ? + ( symbol => $sym, soname => $so ) : $sym; + } + } + } + return; +} + +# Tries to find a pattern like the $refpat and returns its descriptor. +# $refpat may also be a pattern spec. +sub lookup_pattern { + my ($self, $refpat, $sonames, $inc_deprecated) = @_; + $inc_deprecated //= 0; + # If $refsym is a string, we need to create a dummy ref symbol. + $refpat = $self->create_symbol($refpat, dummy => 1) if ! ref($refpat); + + if ($refpat && $refpat->is_pattern()) { + foreach my $soname ((ref($sonames) eq 'ARRAY') ? @$sonames : $sonames) { + if (my $obj = $self->get_object($soname)) { + my $pat; + if (my $type = $refpat->get_alias_type()) { + if (exists $obj->{patterns}{aliases}{$type}) { + $pat = $obj->{patterns}{aliases}{$type}{$refpat->get_symbolname()}; + } + } elsif ($refpat->get_pattern_type() eq 'generic') { + for my $p (@{$obj->{patterns}{generic}}) { + if (($inc_deprecated || !$p->{deprecated}) && + $p->equals($refpat, versioning => 0)) + { + $pat = $p; + last; + } + } + } + if ($pat && ($inc_deprecated || !$pat->{deprecated})) { + return (wantarray) ? + (symbol => $pat, soname => $soname) : $pat; + } + } + } + } + return; +} + +# Get symbol object reference either by symbol name or by a reference object. +sub get_symbol_object { + my ($self, $refsym, $soname) = @_; + my $sym = $self->lookup_symbol($refsym, $soname, 1); + if (! defined $sym) { + $sym = $self->lookup_pattern($refsym, $soname, 1); + } + return $sym; +} + +sub get_new_symbols { + my ($self, $ref, %opts) = @_; + my $with_optional = (exists $opts{with_optional}) ? + $opts{with_optional} : 0; + my @res; + foreach my $soname ($self->get_sonames()) { + next if not $ref->has_object($soname); + + # Scan raw symbols first. + foreach my $sym (grep { ($with_optional || ! $_->is_optional()) + && $_->is_legitimate($self->get_arch()) } + $self->get_symbols($soname)) + { + my $refsym = $ref->lookup_symbol($sym, $soname, 1); + my $isnew; + if (defined $refsym) { + # If the symbol exists in the $ref symbol file, it might + # still be new if $refsym is not legitimate. + $isnew = not $refsym->is_legitimate($self->get_arch()); + } else { + # If the symbol does not exist in the $ref symbol file, it does + # not mean that it's new. It might still match a pattern in the + # symbol file. However, due to performance reasons, first check + # if the pattern that the symbol matches (if any) exists in the + # ref symbol file as well. + $isnew = not ( + ($sym->get_pattern() and $ref->lookup_pattern($sym->get_pattern(), $soname, 1)) or + $ref->find_matching_pattern($sym, $soname, 1) + ); + } + push @res, { symbol => $sym, soname => $soname } if $isnew; + } + + # Now scan patterns + foreach my $p (grep { ($with_optional || ! $_->is_optional()) + && $_->is_legitimate($self->get_arch()) } + $self->get_patterns($soname)) + { + my $refpat = $ref->lookup_pattern($p, $soname, 0); + # If reference pattern was not found or it is not legitimate, + # considering current one as new. + if (not defined $refpat or + not $refpat->is_legitimate($self->get_arch())) + { + push @res, { symbol => $p , soname => $soname }; + } + } + } + return @res; +} + +sub get_lost_symbols { + my ($self, $ref, %opts) = @_; + return $ref->get_new_symbols($self, %opts); +} + + +sub get_new_libs { + my ($self, $ref) = @_; + my @res; + foreach my $soname ($self->get_sonames()) { + push @res, $soname if not $ref->get_object($soname); + } + return @res; +} + +sub get_lost_libs { + my ($self, $ref) = @_; + return $ref->get_new_libs($self); +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Archive.pm b/scripts/Dpkg/Source/Archive.pm new file mode 100644 index 0000000..badb81b --- /dev/null +++ b/scripts/Dpkg/Source/Archive.pm @@ -0,0 +1,264 @@ +# Copyright © 2008 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Archive - source tarball archive support + +=head1 DESCRIPTION + +This module provides a class that implements support for handling +source tarballs. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::Archive 0.01; + +use strict; +use warnings; + +use Carp; +use Errno qw(ENOENT); +use File::Temp qw(tempdir); +use File::Basename qw(basename); +use File::Spec; +use File::Find; +use Cwd; + +use Dpkg (); +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::IPC; +use Dpkg::Source::Functions qw(erasedir fixperms); + +use parent qw(Dpkg::Compression::FileHandle); + +sub create { + my ($self, %opts) = @_; + $opts{options} //= []; + my %spawn_opts; + # Possibly run tar from another directory + if ($opts{chdir}) { + $spawn_opts{chdir} = $opts{chdir}; + *$self->{chdir} = $opts{chdir}; + } + # Redirect input/output appropriately + $self->ensure_open('w'); + $spawn_opts{to_handle} = $self->get_filehandle(); + $spawn_opts{from_pipe} = \*$self->{tar_input}; + # Try to use a deterministic mtime. + my $mtime = $opts{source_date} // $ENV{SOURCE_DATE_EPOCH} || time; + # Call tar creation process + $spawn_opts{delete_env} = [ 'TAR_OPTIONS' ]; + $spawn_opts{exec} = [ + $Dpkg::PROGTAR, '-cf', '-', '--format=gnu', '--sort=name', + '--mtime', "\@$mtime", '--clamp-mtime', '--null', + '--numeric-owner', '--owner=0', '--group=0', + @{$opts{options}}, '-T', '-', + ]; + *$self->{pid} = spawn(%spawn_opts); + *$self->{cwd} = getcwd(); +} + +sub _add_entry { + my ($self, $file) = @_; + my $cwd = *$self->{cwd}; + croak 'call create() first' unless *$self->{tar_input}; + if ($file =~ m{^\Q$cwd\E/(.+)$}) { + # Make pathname relative to the source root directory. + $file = $1; + } + print({ *$self->{tar_input} } "$file\0") + or syserr(g_('write on tar input')); +} + +sub add_file { + my ($self, $file) = @_; + my $testfile = $file; + if (*$self->{chdir}) { + $testfile = File::Spec->catfile(*$self->{chdir}, $file); + } + croak 'add_file() does not handle directories' + if not -l $testfile and -d _; + $self->_add_entry($file); +} + +sub add_directory { + my ($self, $file) = @_; + my $testfile = $file; + if (*$self->{chdir}) { + $testfile = File::Spec->catdir(*$self->{chdir}, $file); + } + croak 'add_directory() only handles directories' + if -l $testfile or not -d _; + $self->_add_entry($file); +} + +sub finish { + my $self = shift; + + close(*$self->{tar_input}) or syserr(g_('close on tar input')); + wait_child(*$self->{pid}, cmdline => "$Dpkg::PROGTAR -cf -"); + delete *$self->{pid}; + delete *$self->{tar_input}; + delete *$self->{cwd}; + delete *$self->{chdir}; + $self->close(); +} + +sub extract { + my ($self, $dest, %opts) = @_; + $opts{options} //= []; + $opts{in_place} //= 0; + $opts{no_fixperms} //= 0; + my %spawn_opts = (wait_child => 1); + + # Prepare destination + my $template = basename($self->get_filename()) . '.tmp-extract.XXXXX'; + unless (-e $dest) { + # Kludge so that realpath works + mkdir($dest) or syserr(g_('cannot create directory %s'), $dest); + } + my $tmp = tempdir($template, DIR => Cwd::realpath("$dest/.."), CLEANUP => 1); + $spawn_opts{chdir} = $tmp; + + # Prepare stuff that handles the input of tar + $self->ensure_open('r', delete_sig => [ 'PIPE' ]); + $spawn_opts{from_handle} = $self->get_filehandle(); + + # Call tar extraction process + $spawn_opts{delete_env} = [ 'TAR_OPTIONS' ]; + $spawn_opts{exec} = [ + $Dpkg::PROGTAR, '-xf', '-', '--no-same-permissions', + '--no-same-owner', @{$opts{options}}, + ]; + spawn(%spawn_opts); + $self->close(); + + # Fix permissions on extracted files because tar insists on applying + # our umask _to the original permissions_ rather than mostly-ignoring + # the original permissions. + # We still need --no-same-permissions because otherwise tar might + # extract directory setgid (which we want inherited, not + # extracted); we need --no-same-owner because putting the owner + # back is tedious - in particular, correct group ownership would + # have to be calculated using mount options and other madness. + fixperms($tmp) unless $opts{no_fixperms}; + + # If we are extracting "in-place" do not remove the destination directory. + if ($opts{in_place}) { + my $canon_basedir = Cwd::realpath($dest); + # On Solaris /dev/null points to /devices/pseudo/mm@0:null. + my $canon_devnull = Cwd::realpath('/dev/null'); + my $check_symlink = sub { + my $pathname = shift; + my $canon_pathname = Cwd::realpath($pathname); + if (not defined $canon_pathname) { + return if $! == ENOENT; + + syserr(g_("pathname '%s' cannot be canonicalized"), $pathname); + } + return if $canon_pathname eq $canon_devnull; + return if $canon_pathname eq $canon_basedir; + return if $canon_pathname =~ m{^\Q$canon_basedir/\E}; + warning(g_("pathname '%s' points outside source root (to '%s')"), + $pathname, $canon_pathname); + }; + + my $move_in_place = sub { + my $relpath = File::Spec->abs2rel($File::Find::name, $tmp); + my $destpath = File::Spec->catfile($dest, $relpath); + + my ($mode, $atime, $mtime); + lstat $File::Find::name + or syserr(g_('cannot get source pathname %s metadata'), $File::Find::name); + ((undef) x 2, $mode, (undef) x 5, $atime, $mtime) = lstat _; + my $src_is_dir = -d _; + + my $dest_exists = 1; + if (not lstat $destpath) { + if ($! == ENOENT) { + $dest_exists = 0; + } else { + syserr(g_('cannot get target pathname %s metadata'), $destpath); + } + } + my $dest_is_dir = -d _; + if ($dest_exists) { + if ($dest_is_dir && $src_is_dir) { + # Refresh the destination directory attributes with the + # ones from the tarball. + chmod $mode, $destpath + or syserr(g_('cannot change directory %s mode'), $File::Find::name); + utime $atime, $mtime, $destpath + or syserr(g_('cannot change directory %s times'), $File::Find::name); + + # We should do nothing, and just walk further tree. + return; + } elsif ($dest_is_dir) { + rmdir $destpath + or syserr(g_('cannot remove destination directory %s'), $destpath); + } else { + $check_symlink->($destpath); + unlink $destpath + or syserr(g_('cannot remove destination file %s'), $destpath); + } + } + # If we are moving a directory, we do not need to walk it. + if ($src_is_dir) { + $File::Find::prune = 1; + } + rename $File::Find::name, $destpath + or syserr(g_('cannot move %s to %s'), $File::Find::name, $destpath); + }; + + find({ + wanted => $move_in_place, + no_chdir => 1, + dangling_symlinks => 0, + }, $tmp); + } else { + # Rename extracted directory + opendir(my $dir_dh, $tmp) or syserr(g_('cannot opendir %s'), $tmp); + my @entries = grep { $_ ne '.' && $_ ne '..' } readdir($dir_dh); + closedir($dir_dh); + + erasedir($dest); + + if (scalar(@entries) == 1 && ! -l "$tmp/$entries[0]" && -d _) { + rename("$tmp/$entries[0]", $dest) + or syserr(g_('unable to rename %s to %s'), + "$tmp/$entries[0]", $dest); + } else { + rename($tmp, $dest) + or syserr(g_('unable to rename %s to %s'), $tmp, $dest); + } + } + erasedir($tmp); +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/BinaryFiles.pm b/scripts/Dpkg/Source/BinaryFiles.pm new file mode 100644 index 0000000..8964110 --- /dev/null +++ b/scripts/Dpkg/Source/BinaryFiles.pm @@ -0,0 +1,182 @@ +# Copyright © 2008-2011 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::BinaryFiles - manipulate debian/source/include-binaries files + +=head1 DESCRIPTION + +This module provides a class to handle the F<debian/source/include-binaries> +file. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::BinaryFiles 0.01; + +use strict; +use warnings; + +use Cwd; +use File::Path qw(make_path); +use File::Spec; +use File::Find; + +use Dpkg::ErrorHandling; +use Dpkg::Gettext; +use Dpkg::Source::Functions qw(is_binary); + +sub new { + my ($this, $dir) = @_; + my $class = ref($this) || $this; + + my $self = { + dir => $dir, + allowed_binaries => {}, + seen_binaries => {}, + include_binaries_path => + File::Spec->catfile($dir, 'debian', 'source', 'include-binaries'), + }; + bless $self, $class; + $self->load_allowed_binaries(); + return $self; +} + +sub new_binary_found { + my ($self, $path) = @_; + + $self->{seen_binaries}{$path} = 1; +} + +sub load_allowed_binaries { + my $self = shift; + my $incbin_file = $self->{include_binaries_path}; + + if (-f $incbin_file) { + open my $incbin_fh, '<', $incbin_file + or syserr(g_('cannot read %s'), $incbin_file); + while (<$incbin_fh>) { + chomp; + s/^\s*//; + s/\s*$//; + next if /^#/ or length == 0; + $self->{allowed_binaries}{$_} = 1; + } + close $incbin_fh; + } +} + +sub binary_is_allowed { + my ($self, $path) = @_; + + return 1 if exists $self->{allowed_binaries}{$path}; + return 0; +} + +sub update_debian_source_include_binaries { + my $self = shift; + + my @unknown_binaries = $self->get_unknown_binaries(); + return unless scalar @unknown_binaries; + + my $incbin_file = $self->{include_binaries_path}; + make_path(File::Spec->catdir($self->{dir}, 'debian', 'source')); + open my $incbin_fh, '>>', $incbin_file + or syserr(g_('cannot write %s'), $incbin_file); + foreach my $binary (@unknown_binaries) { + print { $incbin_fh } "$binary\n"; + info(g_('adding %s to %s'), $binary, 'debian/source/include-binaries'); + $self->{allowed_binaries}{$binary} = 1; + } + close $incbin_fh; +} + +sub get_unknown_binaries { + my $self = shift; + + return grep { not $self->binary_is_allowed($_) } $self->get_seen_binaries(); +} + +sub get_seen_binaries { + my $self = shift; + my @seen = sort keys %{$self->{seen_binaries}}; + + return @seen; +} + +sub detect_binary_files { + my ($self, %opts) = @_; + + my $unwanted_binaries = 0; + my $check_binary = sub { + if (-f and is_binary($_)) { + my $fn = File::Spec->abs2rel($_, $self->{dir}); + $self->new_binary_found($fn); + unless ($opts{include_binaries} or $self->binary_is_allowed($fn)) { + errormsg(g_('unwanted binary file: %s'), $fn); + $unwanted_binaries++; + } + } + }; + my $exclude_glob = '{' . + join(',', map { s/,/\\,/rg } @{$opts{exclude_globs}}) . + '}'; + my $filter_ignore = sub { + # Filter out files that are not going to be included in the debian + # tarball due to ignores. + my %exclude; + my $reldir = File::Spec->abs2rel($File::Find::dir, $self->{dir}); + my $cwd = getcwd(); + # Apply the pattern both from the top dir and from the inspected dir + chdir $self->{dir} + or syserr(g_("unable to chdir to '%s'"), $self->{dir}); + $exclude{$_} = 1 foreach glob $exclude_glob; + chdir $cwd or syserr(g_("unable to chdir to '%s'"), $cwd); + chdir $File::Find::dir + or syserr(g_("unable to chdir to '%s'"), $File::Find::dir); + $exclude{$_} = 1 foreach glob $exclude_glob; + chdir $cwd or syserr(g_("unable to chdir to '%s'"), $cwd); + my @result; + foreach my $fn (@_) { + unless (exists $exclude{$fn} or exists $exclude{"$reldir/$fn"}) { + push @result, $fn; + } + } + return @result; + }; + find({ wanted => $check_binary, preprocess => $filter_ignore, + no_chdir => 1 }, File::Spec->catdir($self->{dir}, 'debian')); + error(P_('detected %d unwanted binary file (add it in ' . + 'debian/source/include-binaries to allow its inclusion).', + 'detected %d unwanted binary files (add them in ' . + 'debian/source/include-binaries to allow their inclusion).', + $unwanted_binaries), $unwanted_binaries) + if $unwanted_binaries; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Format.pm b/scripts/Dpkg/Source/Format.pm new file mode 100644 index 0000000..3adb328 --- /dev/null +++ b/scripts/Dpkg/Source/Format.pm @@ -0,0 +1,189 @@ +# Copyright © 2008-2011 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2018 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Format - manipulate debian/source/format files + +=head1 DESCRIPTION + +This module provides a class that can manipulate Debian source +package F<debian/source/format> files. + +=cut + +package Dpkg::Source::Format 1.00; + +use strict; +use warnings; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +use parent qw(Dpkg::Interface::Storable); + +=head1 METHODS + +=over 4 + +=item $f = Dpkg::Source::Format->new(%opts) + +Creates a new object corresponding to a source package's +F<debian/source/format> file. When the key B<filename> is set, it will +be used to parse and set the format. Otherwise if the B<format> key is +set it will be validated and used to set the format. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + my $self = { + filename => undef, + major => undef, + minor => undef, + variant => undef, + }; + bless $self, $class; + + if (exists $opts{filename}) { + $self->load($opts{filename}, compression => 0); + } elsif ($opts{format}) { + $self->set($opts{format}); + } + return $self; +} + +=item $f->set_from_parts($major[, $minor[, $variant]]) + +Sets the source format from its parts. The $major part is mandatory. +The $minor and $variant parts are optional. + +B<Notice>: This function performs no validation. + +=cut + +sub set_from_parts { + my ($self, $major, $minor, $variant) = @_; + + $self->{major} = $major; + $self->{minor} = $minor // 0; + $self->{variant} = $variant; +} + +=item ($major, $minor, $variant) = $f->set($format) + +Sets (and validates) the source $format specified. Will return the parsed +format parts as a list, the optional $minor and $variant parts might be +undef. + +=cut + +sub set { + my ($self, $format) = @_; + + if ($format =~ /^(\d+)(?:\.(\d+))?(?:\s+\(([a-z0-9]+)\))?$/) { + my ($major, $minor, $variant) = ($1, $2, $3); + + $self->set_from_parts($major, $minor, $variant); + + return ($major, $minor, $variant); + } else { + error(g_("source package format '%s' is invalid"), $format); + } +} + +=item ($major, $minor, $variant) = $f->get() + +=item $format = $f->get() + +Gets the source format, either as properly formatted scalar, or as a list +of its parts, where the optional $minor and $variant parts might be undef. + +=cut + +sub get { + my $self = shift; + + if (wantarray) { + return ($self->{major}, $self->{minor}, $self->{variant}); + } else { + my $format = "$self->{major}.$self->{minor}"; + $format .= " ($self->{variant})" if defined $self->{variant}; + + return $format; + } +} + +=item $count = $f->parse($fh, $desc) + +Parse the source format string from $fh, with filehandle description $desc. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + + my $format = <$fh>; + chomp $format if defined $format; + error(g_('%s is empty'), $desc) + unless defined $format and length $format; + + $self->set($format); + + return 1; +} + +=item $count = $f->load($filename) + +Parse $filename contents for a source package format string. + +=item $str = $f->output([$fh]) + +=item "$f" + +Returns a string representing the source package format version. +If $fh is set, it prints the string to the filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $str = $self->get(); + + print { $fh } "$str\n" if defined $fh; + + return $str; +} + +=item $f->save($filename) + +Save the source package format into the given $filename. + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.19.3) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Functions.pm b/scripts/Dpkg/Source/Functions.pm new file mode 100644 index 0000000..0d1af06 --- /dev/null +++ b/scripts/Dpkg/Source/Functions.pm @@ -0,0 +1,146 @@ +# Copyright © 2008-2010, 2012-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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Functions - miscellaneous source package handling functions + +=head1 DESCRIPTION + +This module provides a set of miscellaneous helper functions to handle +source packages. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::Functions 0.01; + +use strict; +use warnings; + +our @EXPORT_OK = qw( + erasedir + fixperms + chmod_if_needed + fs_time + is_binary +); + +use Exporter qw(import); +use Errno qw(ENOENT); + +use Dpkg::ErrorHandling; +use Dpkg::Gettext; +use Dpkg::File; +use Dpkg::IPC; + +sub erasedir { + my $dir = shift; + if (not lstat($dir)) { + return if $! == ENOENT; + syserr(g_('cannot stat directory %s (before removal)'), $dir); + } + system 'rm', '-rf', '--', $dir; + subprocerr("rm -rf $dir") if $?; + if (not stat($dir)) { + return if $! == ENOENT; + syserr(g_("unable to check for removal of directory '%s'"), $dir); + } + error(g_("rm -rf failed to remove '%s'"), $dir); +} + +sub fixperms { + my $dir = shift; + my ($mode, $modes_set); + # Unfortunately tar insists on applying our umask _to the original + # permissions_ rather than mostly-ignoring the original + # permissions. We fix it up with chmod -R (which saves us some + # work) but we have to construct a u+/- string which is a bit + # of a palaver. (Numeric doesn't work because we need [ugo]+X + # and [ugo]=<stuff> doesn't work because that unsets sgid on dirs.) + $mode = 0777 & ~umask; + for my $i (0 .. 2) { + $modes_set .= ',' if $i; + $modes_set .= qw(u g o)[$i]; + for my $j (0 .. 2) { + $modes_set .= $mode & (0400 >> ($i * 3 + $j)) ? '+' : '-'; + $modes_set .= qw(r w X)[$j]; + } + } + system('chmod', '-R', '--', $modes_set, $dir); + subprocerr("chmod -R -- $modes_set $dir") if $?; +} + +# Only change the pathname permissions if they differ from the desired. +# +# To be able to build a source tree, a user needs write permissions on it, +# but not necessarily ownership of those files. +sub chmod_if_needed { + my ($newperms, $pathname) = @_; + my $oldperms = (stat $pathname)[2] & 07777; + + return 1 if $oldperms == $newperms; + return chmod $newperms, $pathname; +} + +# Touch the file and read the resulting mtime. +# +# If the file doesn't exist, create it, read the mtime and unlink it. +# +# Use this instead of time() when the timestamp is going to be +# used to set file timestamps. This avoids confusion when an +# NFS server and NFS client disagree about what time it is. +sub fs_time($) { + my $file = shift; + my $is_temp = 0; + if (not -e $file) { + file_touch($file); + $is_temp = 1; + } else { + utime(undef, undef, $file) or + syserr(g_('cannot change timestamp for %s'), $file); + } + stat($file) or syserr(g_('cannot read timestamp from %s'), $file); + my $mtime = (stat(_))[9]; + unlink($file) if $is_temp; + return $mtime; +} + +sub is_binary($) { + my $file = shift; + + # Perform the same check as diff(1), look for a NUL character in the first + # 4 KiB of the file. + open my $fh, '<', $file + or syserr(g_('cannot open file %s for binary detection'), $file); + read $fh, my $buf, 4096, 0; + my $res = index $buf, "\0"; + close $fh; + + return $res >= 0; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Package.pm b/scripts/Dpkg/Source/Package.pm new file mode 100644 index 0000000..3427383 --- /dev/null +++ b/scripts/Dpkg/Source/Package.pm @@ -0,0 +1,739 @@ +# Copyright © 2008-2011 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2019 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Package - manipulate Debian source packages + +=head1 DESCRIPTION + +This module provides a class that can manipulate Debian source +packages. While it supports both the extraction and the creation +of source packages, the only API that is officially supported +is the one that supports the extraction of the source package. + +=cut + +package Dpkg::Source::Package 2.02; + +use strict; +use warnings; + +our @EXPORT_OK = qw( + get_default_diff_ignore_regex + set_default_diff_ignore_regex + get_default_tar_ignore_pattern +); + +use Exporter qw(import); +use POSIX qw(:errno_h :sys_wait_h); +use Carp; +use File::Temp; +use File::Copy qw(cp); +use File::Basename; +use File::Spec; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control; +use Dpkg::Checksums; +use Dpkg::Version; +use Dpkg::Compression; +use Dpkg::Path qw(check_files_are_the_same check_directory_traversal); +use Dpkg::Vendor qw(run_vendor_hook); +use Dpkg::Source::Format; +use Dpkg::OpenPGP; +use Dpkg::OpenPGP::ErrorCodes; + +my $diff_ignore_default_regex = ' +# Ignore general backup files +(?:^|/).*~$| +# Ignore emacs recovery files +(?:^|/)\.#.*$| +# Ignore vi swap files +(?:^|/)\..*\.sw.$| +# Ignore baz-style junk files or directories +(?:^|/),,.*(?:$|/.*$)| +# File-names that should be ignored (never directories) +(?:^|/)(?:DEADJOE|\.arch-inventory|\.(?:bzr|cvs|hg|git|mtn-)ignore)$| +# File or directory names that should be ignored +(?:^|/)(?:CVS|RCS|\.deps|\{arch\}|\.arch-ids|\.svn| +\.hg(?:tags|sigs)?|_darcs|\.git(?:attributes|modules|review)?| +\.mailmap|\.shelf|_MTN|\.be|\.bzr(?:\.backup|tags)?)(?:$|/.*$) +'; +# Take out comments and newlines +$diff_ignore_default_regex =~ s/^#.*$//mg; +$diff_ignore_default_regex =~ s/\n//sg; + +no warnings 'qw'; ## no critic (TestingAndDebugging::ProhibitNoWarnings) +my @tar_ignore_default_pattern = qw( +*.a +*.la +*.o +*.so +.*.sw? +*/*~ +,,* +.[#~]* +.arch-ids +.arch-inventory +.be +.bzr +.bzr.backup +.bzr.tags +.bzrignore +.cvsignore +.deps +.git +.gitattributes +.gitignore +.gitmodules +.gitreview +.hg +.hgignore +.hgsigs +.hgtags +.mailmap +.mtn-ignore +.shelf +.svn +CVS +DEADJOE +RCS +_MTN +_darcs +{arch} +); +## use critic + +=head1 FUNCTIONS + +=over 4 + +=item $string = get_default_diff_ignore_regex() + +Returns the default diff ignore regex. + +=cut + +sub get_default_diff_ignore_regex { + return $diff_ignore_default_regex; +} + +=item set_default_diff_ignore_regex($string) + +Set a regex as the new default diff ignore regex. + +=cut + +sub set_default_diff_ignore_regex { + my $regex = shift; + + $diff_ignore_default_regex = $regex; +} + +=item @array = get_default_tar_ignore_pattern() + +Returns the default tar ignore pattern, as an array. + +=cut + +sub get_default_tar_ignore_pattern { + return @tar_ignore_default_pattern; +} + +=back + +=head1 METHODS + +=over 4 + +=item $p = Dpkg::Source::Package->new(%opts, options => {}) + +Creates a new object corresponding to a source package. When the key +B<filename> is set to a F<.dsc> file, it will be used to initialize the +source package with its description. Otherwise if the B<format> key is +set to a valid value, the object will be initialized for that format +(since dpkg 1.19.3). + +The B<options> key is a hash ref which supports the following options: + +=over 8 + +=item skip_debianization + +If set to 1, do not apply Debian changes on the extracted source package. + +=item skip_patches + +If set to 1, do not apply Debian-specific patches. This options is +specific for source packages using format "2.0" and "3.0 (quilt)". + +=item require_valid_signature + +If set to 1, the check_signature() method will be stricter and will error +out if the signature can't be verified. + +=item require_strong_checksums + +If set to 1, the check_checksums() method will be stricter and will error +out if there is no strong checksum. + +=item copy_orig_tarballs + +If set to 1, the extraction will copy the upstream tarballs next the +target directory. This is useful if you want to be able to rebuild the +source package after its extraction. + +=back + +=cut + +# Class methods +sub new { + my ($this, %args) = @_; + my $class = ref($this) || $this; + my $self = { + fields => Dpkg::Control->new(type => CTRL_DSC), + format => Dpkg::Source::Format->new(), + options => {}, + checksums => Dpkg::Checksums->new(), + openpgp => Dpkg::OpenPGP->new(needs => { api => 'verify' }), + }; + bless $self, $class; + if (exists $args{options}) { + $self->{options} = $args{options}; + } + if (exists $args{filename}) { + $self->initialize($args{filename}); + $self->init_options(); + } elsif ($args{format}) { + $self->{fields}{Format} = $args{format}; + $self->upgrade_object_type(0); + $self->init_options(); + } + + if ($self->{options}{require_valid_signature}) { + $self->{report_verify} = \&error; + } else { + $self->{report_verify} = \&warning; + } + + return $self; +} + +sub init_options { + my $self = shift; + # Use full ignore list by default + # note: this function is not called by V1 packages + $self->{options}{diff_ignore_regex} ||= $diff_ignore_default_regex; + $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/source/local-.*$'; + $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/files(?:\.new)?$'; + if (defined $self->{options}{tar_ignore}) { + $self->{options}{tar_ignore} = [ @tar_ignore_default_pattern ] + unless @{$self->{options}{tar_ignore}}; + } else { + $self->{options}{tar_ignore} = [ @tar_ignore_default_pattern ]; + } + push @{$self->{options}{tar_ignore}}, + 'debian/source/local-options', + 'debian/source/local-patch-header', + 'debian/files', + 'debian/files.new'; + $self->{options}{copy_orig_tarballs} //= 0; + + # Skip debianization while specific to some formats has an impact + # on code common to all formats + $self->{options}{skip_debianization} //= 0; + $self->{options}{skip_patches} //= 0; + + # Set default validation checks. + $self->{options}{require_valid_signature} //= 0; + $self->{options}{require_strong_checksums} //= 0; + + # Set default compressor for new formats. + $self->{options}{compression} //= 'xz'; + $self->{options}{comp_level} //= compression_get_level($self->{options}{compression}); + $self->{options}{comp_ext} //= compression_get_file_extension($self->{options}{compression}); +} + +sub initialize { + my ($self, $filename) = @_; + my ($fn, $dir) = fileparse($filename); + error(g_('%s is not the name of a file'), $filename) unless $fn; + $self->{basedir} = $dir || './'; + $self->{filename} = $fn; + + # Read the fields + my $fields = $self->{fields}; + $fields->load($filename); + $self->{is_signed} = $fields->get_option('is_pgp_signed'); + + foreach my $f (qw(Source Version Files)) { + unless (defined($fields->{$f})) { + error(g_('missing critical source control field %s'), $f); + } + } + + $self->{checksums}->add_from_control($fields, use_files_for_md5 => 1); + + $self->upgrade_object_type(0); +} + +sub upgrade_object_type { + my ($self, $update_format) = @_; + $update_format //= 1; + + my $format = $self->{fields}{'Format'} // '1.0'; + my ($major, $minor, $variant) = $self->{format}->set($format); + + my $module = "Dpkg::Source::Package::V$major"; + $module .= '::' . ucfirst $variant if defined $variant; + eval qq{ + require $module; + \$minor = \$${module}::CURRENT_MINOR_VERSION; + }; + if ($@) { + error(g_("source package format '%s' is not supported: %s"), + $format, $@); + } + if ($update_format) { + $self->{format}->set_from_parts($major, $minor, $variant); + $self->{fields}{'Format'} = $self->{format}->get(); + } + + $module->prerequisites() if $module->can('prerequisites'); + bless $self, $module; +} + +=item $p->get_filename() + +Returns the filename of the DSC file. + +=cut + +sub get_filename { + my $self = shift; + return File::Spec->catfile($self->{basedir}, $self->{filename}); +} + +=item $p->get_files() + +Returns the list of files referenced by the source package. The filenames +usually do not have any path information. + +=cut + +sub get_files { + my $self = shift; + return $self->{checksums}->get_files(); +} + +=item $p->check_checksums() + +Verify the checksums embedded in the DSC file. It requires the presence of +the other files constituting the source package. If any inconsistency is +discovered, it immediately errors out. It will make sure at least one strong +checksum is present. + +If the object has been created with the "require_strong_checksums" option, +then any problem will result in a fatal error. + +=cut + +sub check_checksums { + my $self = shift; + my $checksums = $self->{checksums}; + my $warn_on_weak = 0; + + # add_from_file verify the checksums if they are already existing + foreach my $file ($checksums->get_files()) { + if (not $checksums->has_strong_checksums($file)) { + if ($self->{options}{require_strong_checksums}) { + error(g_('source package uses only weak checksums')); + } else { + $warn_on_weak = 1; + } + } + my $pathname = File::Spec->catfile($self->{basedir}, $file); + $checksums->add_from_file($pathname, key => $file); + } + + warning(g_('source package uses only weak checksums')) if $warn_on_weak; +} + +sub get_basename { + my ($self, $with_revision) = @_; + my $f = $self->{fields}; + unless (exists $f->{'Source'} and exists $f->{'Version'}) { + error(g_('%s and %s fields are required to compute the source basename'), + 'Source', 'Version'); + } + my $v = Dpkg::Version->new($f->{'Version'}); + my $vs = $v->as_string(omit_epoch => 1, omit_revision => !$with_revision); + return $f->{'Source'} . '_' . $vs; +} + +sub find_original_tarballs { + my ($self, %opts) = @_; + $opts{extension} //= compression_get_file_extension_regex(); + $opts{include_main} //= 1; + $opts{include_supplementary} //= 1; + my $basename = $self->get_basename(); + my @tar; + foreach my $dir ('.', $self->{basedir}, $self->{options}{origtardir}) { + next unless defined($dir) and -d $dir; + opendir(my $dir_dh, $dir) or syserr(g_('cannot opendir %s'), $dir); + push @tar, map { File::Spec->catfile($dir, $_) } grep { + ($opts{include_main} and + /^\Q$basename\E\.orig\.tar\.$opts{extension}$/) or + ($opts{include_supplementary} and + /^\Q$basename\E\.orig-[[:alnum:]-]+\.tar\.$opts{extension}$/) + } readdir($dir_dh); + closedir($dir_dh); + } + return @tar; +} + +=item $p->get_upstream_signing_key($dir) + +Get the filename for the upstream key. + +=cut + +sub get_upstream_signing_key { + my ($self, $dir) = @_; + + return "$dir/debian/upstream/signing-key.asc"; +} + +=item $p->armor_original_tarball_signature($bin, $asc) + +Convert a signature from binary to ASCII armored form. If the signature file +does not exist, it is a no-op. If the signature file is already ASCII armored +then simply copy it, otherwise convert it from binary to ASCII armored form. + +=cut + +sub armor_original_tarball_signature { + my ($self, $bin, $asc) = @_; + + if (-e $bin) { + return $self->{openpgp}->armor('SIGNATURE', $bin, $asc); + } + + return; +} + +=item $p->check_original_tarball_signature($dir, @asc) + +Verify the original upstream tarball signatures @asc using the upstream +public keys. It requires the origin upstream tarballs, their signatures +and the upstream signing key, as found in an unpacked source tree $dir. +If any inconsistency is discovered, it immediately errors out. + +=cut + +sub check_original_tarball_signature { + my ($self, $dir, @asc) = @_; + + my $upstream_key = $self->get_upstream_signing_key($dir); + if (not -e $upstream_key) { + warning(g_('upstream tarball signatures but no upstream signing key')); + return; + } + + foreach my $asc (@asc) { + my $datafile = $asc =~ s/\.asc$//r; + + info(g_('verifying %s'), $asc); + my $rc = $self->{openpgp}->verify($datafile, $asc, $upstream_key); + if ($rc) { + $self->{report_verify}->(g_('cannot verify upstream tarball signature for %s: %s'), + $datafile, openpgp_errorcode_to_string($rc)); + } + } +} + +=item $bool = $p->is_signed() + +Returns 1 if the DSC files contains an embedded OpenPGP signature. +Otherwise returns 0. + +=cut + +sub is_signed { + my $self = shift; + return $self->{is_signed}; +} + +=item $p->check_signature() + +Implement the same OpenPGP signature check that dpkg-source does. +In case of problems, it prints a warning or errors out. + +If the object has been created with the "require_valid_signature" option, +then any problem will result in a fatal error. + +=cut + +sub check_signature { + my $self = shift; + my $dsc = $self->get_filename(); + my @certs; + + push @certs, $self->{openpgp}->get_trusted_keyrings(); + + foreach my $vendor_keyring (run_vendor_hook('package-keyrings')) { + if (-r $vendor_keyring) { + push @certs, $vendor_keyring; + } + } + + my $rc = $self->{openpgp}->inline_verify($dsc, undef, @certs); + if ($rc) { + $self->{report_verify}->(g_('cannot verify inline signature for %s: %s'), + $dsc, openpgp_errorcode_to_string($rc)); + } +} + +sub describe_cmdline_options { + return; +} + +sub parse_cmdline_options { + my ($self, @opts) = @_; + foreach my $option (@opts) { + if (not $self->parse_cmdline_option($option)) { + warning(g_('%s is not a valid option for %s'), $option, ref $self); + } + } +} + +sub parse_cmdline_option { + return 0; +} + +=item $p->extract($targetdir) + +Extracts the source package in the target directory $targetdir. Beware +that if $targetdir already exists, it will be erased (as long as the +no_overwrite_dir option is set). + +=cut + +sub extract { + my ($self, $newdirectory) = @_; + + my ($ok, $error) = version_check($self->{fields}{'Version'}); + if (not $ok) { + if ($self->{options}{ignore_bad_version}) { + warning($error); + } else { + error($error); + } + } + + # Copy orig tarballs + if ($self->{options}{copy_orig_tarballs}) { + my $basename = $self->get_basename(); + my ($dirname, $destdir) = fileparse($newdirectory); + $destdir ||= './'; + my $ext = compression_get_file_extension_regex(); + foreach my $orig (grep { /^\Q$basename\E\.orig(-[[:alnum:]-]+)?\.tar\.$ext$/ } + $self->get_files()) + { + my $src = File::Spec->catfile($self->{basedir}, $orig); + my $dst = File::Spec->catfile($destdir, $orig); + if (not check_files_are_the_same($src, $dst, 1)) { + cp($src, $dst) + or syserr(g_('cannot copy %s to %s'), $src, $dst); + } + } + } + + # Try extract + $self->do_extract($newdirectory); + + # Check for directory traversals. + if (not $self->{options}{skip_debianization} and not $self->{no_check}) { + # We need to add a trailing slash to handle the debian directory + # possibly being a symlink. + check_directory_traversal($newdirectory, "$newdirectory/debian/"); + } + + # Store format if non-standard so that next build keeps the same format + if ($self->{fields}{'Format'} and + $self->{fields}{'Format'} ne '1.0' and + not $self->{options}{skip_debianization}) + { + my $srcdir = File::Spec->catdir($newdirectory, 'debian', 'source'); + my $format_file = File::Spec->catfile($srcdir, 'format'); + unless (-e $format_file) { + mkdir($srcdir) unless -e $srcdir; + $self->{format}->save($format_file); + } + } + + # Make sure debian/rules is executable + my $rules = File::Spec->catfile($newdirectory, 'debian', 'rules'); + my @s = lstat($rules); + if (not scalar(@s)) { + unless ($! == ENOENT) { + syserr(g_('cannot stat %s'), $rules); + } + warning(g_('%s does not exist'), $rules) + unless $self->{options}{skip_debianization}; + } elsif (-f _) { + chmod($s[2] | 0111, $rules) + or syserr(g_('cannot make %s executable'), $rules); + } else { + warning(g_('%s is not a plain file'), $rules); + } +} + +sub do_extract { + croak 'Dpkg::Source::Package does not know how to unpack a ' . + 'source package; use one of the subclasses'; +} + +# Function used specifically during creation of a source package + +sub before_build { + my ($self, $dir) = @_; +} + +sub build { + my ($self, @args) = @_; + + $self->do_build(@args); +} + +sub after_build { + my ($self, $dir) = @_; +} + +sub do_build { + croak 'Dpkg::Source::Package does not know how to build a ' . + 'source package; use one of the subclasses'; +} + +sub can_build { + my ($self, $dir) = @_; + return (0, 'can_build() has not been overridden'); +} + +sub add_file { + my ($self, $filename) = @_; + my ($fn, $dir) = fileparse($filename); + if ($self->{checksums}->has_file($fn)) { + croak "tried to add file '$fn' twice"; + } + $self->{checksums}->add_from_file($filename, key => $fn); + $self->{checksums}->export_to_control($self->{fields}, + use_files_for_md5 => 1); +} + +sub commit { + my ($self, @args) = @_; + + $self->do_commit(@args); +} + +sub do_commit { + my ($self, $dir) = @_; + info(g_("'%s' is not supported by the source format '%s'"), + 'dpkg-source --commit', $self->{fields}{'Format'}); +} + +sub write_dsc { + my ($self, %opts) = @_; + my $fields = $self->{fields}; + + foreach my $f (keys %{$opts{override}}) { + $fields->{$f} = $opts{override}{$f}; + } + + unless ($opts{nocheck}) { + foreach my $f (qw(Source Version Architecture)) { + unless (defined($fields->{$f})) { + error(g_('missing information for critical output field %s'), $f); + } + } + foreach my $f (qw(Maintainer Standards-Version)) { + unless (defined($fields->{$f})) { + warning(g_('missing information for output field %s'), $f); + } + } + } + + foreach my $f (keys %{$opts{remove}}) { + delete $fields->{$f}; + } + + my $filename = $opts{filename}; + $filename //= $self->get_basename(1) . '.dsc'; + open(my $dsc_fh, '>', $filename) + or syserr(g_('cannot write %s'), $filename); + $fields->apply_substvars($opts{substvars}); + $fields->output($dsc_fh); + close($dsc_fh); +} + +=back + +=head1 CHANGES + +=head2 Version 2.02 (dpkg 1.21.10) + +New method: armor_original_tarball_signature(). + +=head2 Version 2.01 (dpkg 1.20.1) + +New method: get_upstream_signing_key(). + +=head2 Version 2.00 (dpkg 1.20.0) + +New method: check_original_tarball_signature(). + +Remove variable: $diff_ignore_default_regexp. + +Hide variable: @tar_ignore_default_pattern. + +=head2 Version 1.03 (dpkg 1.19.3) + +New option: format in new(). + +=head2 Version 1.02 (dpkg 1.18.7) + +New option: require_strong_checksums in check_checksums(). + +=head2 Version 1.01 (dpkg 1.17.2) + +New functions: get_default_diff_ignore_regex(), set_default_diff_ignore_regex(), +get_default_tar_ignore_pattern() + +Deprecated variables: $diff_ignore_default_regexp, @tar_ignore_default_pattern + +=head2 Version 1.00 (dpkg 1.16.1) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Package/V1.pm b/scripts/Dpkg/Source/Package/V1.pm new file mode 100644 index 0000000..170ffe1 --- /dev/null +++ b/scripts/Dpkg/Source/Package/V1.pm @@ -0,0 +1,532 @@ +# Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008, 2012-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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Package::V1 - class for source format 1.0 + +=head1 DESCRIPTION + +This module provides a class to handle the source package format 1.0. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::Package::V1 0.01; + +use strict; +use warnings; + +use Errno qw(ENOENT); +use Cwd; +use File::Basename; +use File::Temp qw(tempfile); +use File::Spec; + +use Dpkg (); +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Compression; +use Dpkg::Source::Archive; +use Dpkg::Source::Patch; +use Dpkg::Exit qw(push_exit_handler pop_exit_handler); +use Dpkg::Source::Functions qw(erasedir); +use Dpkg::Source::Package::V3::Native; + +use parent qw(Dpkg::Source::Package); + +our $CURRENT_MINOR_VERSION = '0'; + +sub init_options { + my $self = shift; + + # Don't call $self->SUPER::init_options() on purpose, V1.0 has no + # ignore by default + if ($self->{options}{diff_ignore_regex}) { + $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/source/local-.*$'; + } else { + $self->{options}{diff_ignore_regex} = '(?:^|/)debian/source/local-.*$'; + } + $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/files(?:\.new)?$'; + push @{$self->{options}{tar_ignore}}, + 'debian/source/local-options', + 'debian/source/local-patch-header', + 'debian/files', + 'debian/files.new'; + $self->{options}{sourcestyle} //= 'X'; + $self->{options}{skip_debianization} //= 0; + $self->{options}{ignore_bad_version} //= 0; + $self->{options}{abort_on_upstream_changes} //= 0; + + # Set default validation checks. + $self->{options}{require_valid_signature} //= 0; + $self->{options}{require_strong_checksums} //= 0; + + # V1.0 only supports gzip compression. + $self->{options}{compression} //= 'gzip'; + $self->{options}{comp_level} //= compression_get_level('gzip'); + $self->{options}{comp_ext} //= compression_get_file_extension('gzip'); +} + +my @module_cmdline = ( + { + name => '-sa', + help => N_('auto select original source'), + when => 'build', + }, { + name => '-sk', + help => N_('use packed original source (unpack and keep)'), + when => 'build', + }, { + name => '-sp', + help => N_('use packed original source (unpack and remove)'), + when => 'build', + }, { + name => '-su', + help => N_('use unpacked original source (pack and keep)'), + when => 'build', + }, { + name => '-sr', + help => N_('use unpacked original source (pack and remove)'), + when => 'build', + }, { + name => '-ss', + help => N_('trust packed and unpacked original sources are same'), + when => 'build', + }, { + name => '-sn', + help => N_('there is no diff, do main tarfile only'), + when => 'build', + }, { + name => '-sA, -sK, -sP, -sU, -sR', + help => N_('like -sa, -sk, -sp, -su, -sr but may overwrite'), + when => 'build', + }, { + name => '--abort-on-upstream-changes', + help => N_('abort if generated diff has upstream files changes'), + when => 'build', + }, { + name => '-sp', + help => N_('leave original source packed in current directory'), + when => 'extract', + }, { + name => '-su', + help => N_('do not copy original source to current directory'), + when => 'extract', + }, { + name => '-sn', + help => N_('unpack original source tree too'), + when => 'extract', + }, { + name => '--skip-debianization', + help => N_('do not apply debian diff to upstream sources'), + when => 'extract', + }, +); + +sub describe_cmdline_options { + return @module_cmdline; +} + +sub parse_cmdline_option { + my ($self, $opt) = @_; + my $o = $self->{options}; + if ($opt =~ m/^-s([akpursnAKPUR])$/) { + warning(g_('-s%s option overrides earlier -s%s option'), $1, + $o->{sourcestyle}) if $o->{sourcestyle} ne 'X'; + $o->{sourcestyle} = $1; + $o->{copy_orig_tarballs} = 0 if $1 eq 'n'; # Extract option -sn + return 1; + } elsif ($opt eq '--skip-debianization') { + $o->{skip_debianization} = 1; + return 1; + } elsif ($opt eq '--ignore-bad-version') { + $o->{ignore_bad_version} = 1; + return 1; + } elsif ($opt eq '--abort-on-upstream-changes') { + $o->{abort_on_upstream_changes} = 1; + return 1; + } + return 0; +} + +sub do_extract { + my ($self, $newdirectory) = @_; + my $sourcestyle = $self->{options}{sourcestyle}; + my $fields = $self->{fields}; + + $sourcestyle =~ y/X/p/; + unless ($sourcestyle =~ m/[pun]/) { + usageerr(g_('source handling style -s%s not allowed with -x'), + $sourcestyle); + } + + my $basename = $self->get_basename(); + my $basenamerev = $self->get_basename(1); + + # V1.0 only supports gzip compression + my ($tarfile, $difffile); + my $tarsign; + foreach my $file ($self->get_files()) { + if ($file =~ /^(?:\Q$basename\E\.orig|\Q$basenamerev\E)\.tar\.gz$/) { + error(g_('multiple tarfiles in v1.0 source package')) if $tarfile; + $tarfile = $file; + } elsif ($file =~ /^\Q$basename\E\.orig\.tar\.gz\.asc$/) { + $tarsign = $file; + } elsif ($file =~ /^\Q$basenamerev\E\.diff\.gz$/) { + $difffile = $file; + } else { + error(g_('unrecognized file for a %s source package: %s'), + 'v1.0', $file); + } + } + + error(g_('no tarfile in Files field')) unless $tarfile; + my $native = $difffile ? 0 : 1; + if ($native and ($tarfile =~ /\.orig\.tar\.gz$/)) { + warning(g_('native package with .orig.tar')); + $native = 0; # V3::Native doesn't handle orig.tar + } + + if ($native) { + Dpkg::Source::Package::V3::Native::do_extract($self, $newdirectory); + } else { + my $expectprefix = $newdirectory; + $expectprefix .= '.orig'; + + if ($self->{options}{no_overwrite_dir} and -e $newdirectory) { + error(g_('unpack target exists: %s'), $newdirectory); + } else { + erasedir($newdirectory); + } + if (-e $expectprefix) { + rename($expectprefix, "$newdirectory.tmp-keep") + or syserr(g_("unable to rename '%s' to '%s'"), $expectprefix, + "$newdirectory.tmp-keep"); + } + + info(g_('unpacking %s'), $tarfile); + my $tar = Dpkg::Source::Archive->new( + filename => File::Spec->catfile($self->{basedir}, $tarfile), + ); + $tar->extract($expectprefix); + + if ($sourcestyle =~ /u/) { + # -su: keep .orig directory unpacked + if (-e "$newdirectory.tmp-keep") { + error(g_('unable to keep orig directory (already exists)')); + } + system('cp', '-ar', '--', $expectprefix, "$newdirectory.tmp-keep"); + subprocerr("cp $expectprefix to $newdirectory.tmp-keep") if $?; + } + + rename($expectprefix, $newdirectory) + or syserr(g_('failed to rename newly-extracted %s to %s'), + $expectprefix, $newdirectory); + + # rename the copied .orig directory + if (-e "$newdirectory.tmp-keep") { + rename("$newdirectory.tmp-keep", $expectprefix) + or syserr(g_('failed to rename saved %s to %s'), + "$newdirectory.tmp-keep", $expectprefix); + } + } + + if ($difffile and not $self->{options}{skip_debianization}) { + my $patch = File::Spec->catfile($self->{basedir}, $difffile); + info(g_('applying %s'), $difffile); + my $patch_obj = Dpkg::Source::Patch->new(filename => $patch); + my $analysis = $patch_obj->apply($newdirectory, force_timestamp => 1); + my @files = grep { ! m{^\Q$newdirectory\E/debian/} } + sort keys %{$analysis->{filepatched}}; + info(g_('upstream files that have been modified: %s'), + "\n " . join("\n ", @files)) if scalar @files; + } +} + +sub can_build { + my ($self, $dir) = @_; + + # As long as we can use gzip, we can do it as we have + # native packages as fallback + return (0, g_('only supports gzip compression')) + unless $self->{options}{compression} eq 'gzip'; + return 1; +} + +sub do_build { + my ($self, $dir) = @_; + my $sourcestyle = $self->{options}{sourcestyle}; + my @argv = @{$self->{options}{ARGV}}; + my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}}; + my $diff_ignore_regex = $self->{options}{diff_ignore_regex}; + + if (scalar(@argv) > 1) { + usageerr(g_('-b takes at most a directory and an orig source ' . + 'argument (with v1.0 source package)')); + } + + $sourcestyle =~ y/X/a/; + unless ($sourcestyle =~ m/[akpursnAKPUR]/) { + usageerr(g_('source handling style -s%s not allowed with -b'), + $sourcestyle); + } + + my $sourcepackage = $self->{fields}{'Source'}; + my $basenamerev = $self->get_basename(1); + my $basename = $self->get_basename(); + my $basedirname = $basename; + $basedirname =~ s/_/-/; + + # Try to find a .orig tarball for the package + my $origdir = "$dir.orig"; + my $origtargz = $self->get_basename() . '.orig.tar.gz'; + if (-e $origtargz) { + unless (-f $origtargz) { + error(g_("packed orig '%s' exists but is not a plain file"), $origtargz); + } + } else { + $origtargz = undef; + } + + if (@argv) { + # We have a second-argument <orig-dir> or <orig-targz>, check what it + # is to decide the mode to use + my $origarg = shift(@argv); + if (length($origarg)) { + stat($origarg) + or syserr(g_('cannot stat orig argument %s'), $origarg); + if (-d _) { + $origdir = File::Spec->catdir($origarg); + + $sourcestyle =~ y/aA/rR/; + unless ($sourcestyle =~ m/[ursURS]/) { + error(g_('orig argument is unpacked but source handling ' . + 'style -s%s calls for packed (.orig.tar.<ext>)'), + $sourcestyle); + } + } elsif (-f _) { + $origtargz = $origarg; + $sourcestyle =~ y/aA/pP/; + unless ($sourcestyle =~ m/[kpsKPS]/) { + error(g_('orig argument is packed but source handling ' . + 'style -s%s calls for unpacked (.orig/)'), + $sourcestyle); + } + } else { + error(g_('orig argument %s is not a plain file or directory'), + $origarg); + } + } else { + $sourcestyle =~ y/aA/nn/; + unless ($sourcestyle =~ m/n/) { + error(g_('orig argument is empty (means no orig, no diff) ' . + 'but source handling style -s%s wants something'), + $sourcestyle); + } + } + } elsif ($sourcestyle =~ m/[aA]/) { + # We have no explicit <orig-dir> or <orig-targz>, try to use + # a .orig tarball first, then a .orig directory and fall back to + # creating a native .tar.gz + if ($origtargz) { + $sourcestyle =~ y/aA/pP/; # .orig.tar.<ext> + } else { + if (stat($origdir)) { + unless (-d _) { + error(g_("unpacked orig '%s' exists but is not a directory"), + $origdir); + } + $sourcestyle =~ y/aA/rR/; # .orig directory + } elsif ($! != ENOENT) { + syserr(g_("unable to stat putative unpacked orig '%s'"), $origdir); + } else { + $sourcestyle =~ y/aA/nn/; # Native tar.gz + } + } + } + + my $v = Dpkg::Version->new($self->{fields}->{'Version'}); + if ($sourcestyle =~ m/[kpursKPUR]/) { + error(g_('non-native package version does not contain a revision')) + if $v->is_native(); + } else { + # TODO: This will become fatal in the near future. + warning(g_('native package version may not have a revision')) + unless $v->is_native(); + } + + my ($dirname, $dirbase) = fileparse($dir); + if ($dirname ne $basedirname) { + warning(g_("source directory '%s' is not <sourcepackage>" . + "-<upstreamversion> '%s'"), $dir, $basedirname); + } + + my ($tarname, $tardirname, $tardirbase); + my $tarsign; + if ($sourcestyle ne 'n') { + my ($origdirname, $origdirbase) = fileparse($origdir); + + if ($origdirname ne "$basedirname.orig") { + warning(g_('.orig directory name %s is not <package>' . + '-<upstreamversion> (wanted %s)'), + $origdirname, "$basedirname.orig"); + } + $tardirbase = $origdirbase; + $tardirname = $origdirname; + + $tarname = $origtargz || "$basename.orig.tar.gz"; + $tarsign = "$tarname.asc"; + unless ($tarname =~ /\Q$basename\E\.orig\.tar\.gz/) { + warning(g_('.orig.tar name %s is not <package>_<upstreamversion>' . + '.orig.tar (wanted %s)'), + $tarname, "$basename.orig.tar.gz"); + } + } + + if ($sourcestyle eq 'n') { + $self->{options}{ARGV} = []; # ensure we have no error + Dpkg::Source::Package::V3::Native::do_build($self, $dir); + } elsif ($sourcestyle =~ m/[urUR]/) { + if (stat($tarname)) { + unless ($sourcestyle =~ m/[UR]/) { + error(g_("tarfile '%s' already exists, not overwriting, " . + 'giving up; use -sU or -sR to override'), $tarname); + } + } elsif ($! != ENOENT) { + syserr(g_("unable to check for existence of '%s'"), $tarname); + } + + info(g_('building %s in %s'), + $sourcepackage, $tarname); + + my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX", + DIR => getcwd(), UNLINK => 0); + my $tar = Dpkg::Source::Archive->new(filename => $newtar, + compression => compression_guess_from_filename($tarname), + compression_level => $self->{options}{comp_level}); + $tar->create(options => \@tar_ignore, chdir => $tardirbase); + $tar->add_directory($tardirname); + $tar->finish(); + rename($newtar, $tarname) + or syserr(g_("unable to rename '%s' (newly created) to '%s'"), + $newtar, $tarname); + chmod(0666 &~ umask(), $tarname) + or syserr(g_("unable to change permission of '%s'"), $tarname); + } else { + info(g_('building %s using existing %s'), + $sourcepackage, $tarname); + } + + if ($tarname) { + $self->add_file($tarname); + if (-e "$tarname.sig" and not -e "$tarname.asc") { + $self->armor_original_tarball_signature("$tarname.sig", "$tarname.asc"); + } + } + if ($tarsign and -e $tarsign) { + $self->check_original_tarball_signature($dir, $tarsign); + + info(g_('building %s using existing %s'), $sourcepackage, $tarsign); + $self->add_file($tarsign); + } else { + my $key = $self->get_upstream_signing_key($dir); + if (-e $key) { + warning(g_('upstream signing key but no upstream tarball signature')); + } + } + + if ($sourcestyle =~ m/[kpKP]/) { + if (stat($origdir)) { + unless ($sourcestyle =~ m/[KP]/) { + error(g_("orig directory '%s' already exists, not overwriting, ". + 'giving up; use -sA, -sK or -sP to override'), + $origdir); + } + erasedir($origdir); + } elsif ($! != ENOENT) { + syserr(g_("unable to check for existence of orig directory '%s'"), + $origdir); + } + + my $tar = Dpkg::Source::Archive->new(filename => $origtargz); + $tar->extract($origdir); + } + + my $ur; # Unrepresentable changes + if ($sourcestyle =~ m/[kpursKPUR]/) { + my $diffname = "$basenamerev.diff.gz"; + info(g_('building %s in %s'), + $sourcepackage, $diffname); + my ($ndfh, $newdiffgz) = tempfile("$diffname.new.XXXXXX", + DIR => getcwd(), UNLINK => 0); + push_exit_handler(sub { unlink($newdiffgz) }); + my $diff = Dpkg::Source::Patch->new(filename => $newdiffgz, + compression => 'gzip', + compression_level => $self->{options}{comp_level}); + $diff->create(); + $diff->add_diff_directory($origdir, $dir, + basedirname => $basedirname, + diff_ignore_regex => $diff_ignore_regex, + options => []); # Force empty set of options to drop the + # default -p option + $diff->finish() || $ur++; + pop_exit_handler(); + + my $analysis = $diff->analyze($origdir); + my @files = grep { ! m{^debian/} } + map { s{^[^/]+/+}{}r } + sort keys %{$analysis->{filepatched}}; + if (scalar @files) { + warning(g_('the diff modifies the following upstream files: %s'), + "\n " . join("\n ", @files)); + info(g_("use the '3.0 (quilt)' format to have separate and " . + 'documented changes to upstream files, see dpkg-source(1)')); + error(g_('aborting due to --abort-on-upstream-changes')) + if $self->{options}{abort_on_upstream_changes}; + } + + rename($newdiffgz, $diffname) + or syserr(g_("unable to rename '%s' (newly created) to '%s'"), + $newdiffgz, $diffname); + chmod(0666 &~ umask(), $diffname) + or syserr(g_("unable to change permission of '%s'"), $diffname); + + $self->add_file($diffname); + } + + if ($sourcestyle =~ m/[prPR]/) { + erasedir($origdir); + } + + if ($ur) { + errormsg(g_('unrepresentable changes to source')); + exit(1); + } +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Package/V2.pm b/scripts/Dpkg/Source/Package/V2.pm new file mode 100644 index 0000000..1f09461 --- /dev/null +++ b/scripts/Dpkg/Source/Package/V2.pm @@ -0,0 +1,766 @@ +# Copyright © 2008-2011 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Package::V2 - class for source format 2.0 + +=head1 DESCRIPTION + +This module provides a class to handle the source package format 2.0. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::Package::V2 0.01; + +use strict; +use warnings; + +use List::Util qw(first); +use Cwd; +use File::Basename; +use File::Temp qw(tempfile tempdir); +use File::Path qw(make_path); +use File::Spec; +use File::Find; +use File::Copy; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::File; +use Dpkg::Path qw(find_command); +use Dpkg::Compression; +use Dpkg::Source::Archive; +use Dpkg::Source::Patch; +use Dpkg::Source::BinaryFiles; +use Dpkg::Exit qw(push_exit_handler pop_exit_handler); +use Dpkg::Source::Functions qw(erasedir chmod_if_needed fs_time); +use Dpkg::Vendor qw(run_vendor_hook); +use Dpkg::Control; +use Dpkg::Changelog::Parse; + +use parent qw(Dpkg::Source::Package); + +our $CURRENT_MINOR_VERSION = '0'; + +sub init_options { + my $self = shift; + $self->SUPER::init_options(); + $self->{options}{include_removal} //= 0; + $self->{options}{include_timestamp} //= 0; + $self->{options}{include_binaries} //= 0; + $self->{options}{preparation} //= 1; + $self->{options}{skip_patches} //= 0; + $self->{options}{unapply_patches} //= 'auto'; + $self->{options}{skip_debianization} //= 0; + $self->{options}{create_empty_orig} //= 0; + $self->{options}{auto_commit} //= 0; + $self->{options}{ignore_bad_version} //= 0; +} + +my @module_cmdline = ( + { + name => '--include-removal', + help => N_('include removed files in the patch'), + when => 'build', + }, { + name => '--include-timestamp', + help => N_('include timestamp in the patch'), + when => 'build', + }, { + name => '--include-binaries', + help => N_('include binary files in the tarball'), + when => 'build', + }, { + name => '--no-preparation', + help => N_('do not prepare build tree by applying patches'), + when => 'build', + }, { + name => '--no-unapply-patches', + help => N_('do not unapply patches if previously applied'), + when => 'build', + }, { + name => '--unapply-patches', + help => N_('unapply patches if previously applied (default)'), + when => 'build', + }, { + name => '--create-empty-orig', + help => N_('create an empty original tarball if missing'), + when => 'build', + }, { + name => '--abort-on-upstream-changes', + help => N_('abort if generated diff has upstream files changes'), + when => 'build', + }, { + name => '--auto-commit', + help => N_('record generated patches, instead of aborting'), + when => 'build', + }, { + name => '--skip-debianization', + help => N_('do not extract debian tarball into upstream sources'), + when => 'extract', + }, { + name => '--skip-patches', + help => N_('do not apply patches at the end of the extraction'), + when => 'extract', + } +); + +sub describe_cmdline_options { + return @module_cmdline; +} + +sub parse_cmdline_option { + my ($self, $opt) = @_; + if ($opt eq '--include-removal') { + $self->{options}{include_removal} = 1; + return 1; + } elsif ($opt eq '--include-timestamp') { + $self->{options}{include_timestamp} = 1; + return 1; + } elsif ($opt eq '--include-binaries') { + $self->{options}{include_binaries} = 1; + return 1; + } elsif ($opt eq '--no-preparation') { + $self->{options}{preparation} = 0; + return 1; + } elsif ($opt eq '--skip-patches') { + $self->{options}{skip_patches} = 1; + return 1; + } elsif ($opt eq '--unapply-patches') { + $self->{options}{unapply_patches} = 'yes'; + return 1; + } elsif ($opt eq '--no-unapply-patches') { + $self->{options}{unapply_patches} = 'no'; + return 1; + } elsif ($opt eq '--skip-debianization') { + $self->{options}{skip_debianization} = 1; + return 1; + } elsif ($opt eq '--create-empty-orig') { + $self->{options}{create_empty_orig} = 1; + return 1; + } elsif ($opt eq '--abort-on-upstream-changes') { + $self->{options}{auto_commit} = 0; + return 1; + } elsif ($opt eq '--auto-commit') { + $self->{options}{auto_commit} = 1; + return 1; + } elsif ($opt eq '--ignore-bad-version') { + $self->{options}{ignore_bad_version} = 1; + return 1; + } + return 0; +} + +sub do_extract { + my ($self, $newdirectory) = @_; + my $fields = $self->{fields}; + + my $basename = $self->get_basename(); + my $basenamerev = $self->get_basename(1); + + my ($tarfile, $debianfile, %addonfile, %seen); + my ($tarsign, %addonsign); + my $re_ext = compression_get_file_extension_regex(); + foreach my $file ($self->get_files()) { + my $uncompressed = $file; + $uncompressed =~ s/\.$re_ext$/.*/; + $uncompressed =~ s/\.$re_ext\.asc$/.*.asc/; + error(g_('duplicate files in %s source package: %s'), 'v2.0', + $uncompressed) if $seen{$uncompressed}; + $seen{$uncompressed} = 1; + if ($file =~ /^\Q$basename\E\.orig\.tar\.$re_ext$/) { + $tarfile = $file; + } elsif ($file =~ /^\Q$basename\E\.orig\.tar\.$re_ext\.asc$/) { + $tarsign = $file; + } elsif ($file =~ /^\Q$basename\E\.orig-([[:alnum:]-]+)\.tar\.$re_ext$/) { + $addonfile{$1} = $file; + } elsif ($file =~ /^\Q$basename\E\.orig-([[:alnum:]-]+)\.tar\.$re_ext\.asc$/) { + $addonsign{$1} = $file; + } elsif ($file =~ /^\Q$basenamerev\E\.debian\.tar\.$re_ext$/) { + $debianfile = $file; + } else { + error(g_('unrecognized file for a %s source package: %s'), + 'v2.0', $file); + } + } + + unless ($tarfile and $debianfile) { + error(g_('missing orig.tar or debian.tar file in v2.0 source package')); + } + if ($tarsign and $tarfile ne substr $tarsign, 0, -4) { + error(g_('mismatched orig.tar %s for signature %s in source package'), + $tarfile, $tarsign); + } + foreach my $name (keys %addonsign) { + error(g_('missing addon orig.tar for signature %s in source package'), + $addonsign{$name}) + if not exists $addonfile{$name}; + error(g_('mismatched addon orig.tar %s for signature %s in source package'), + $addonfile{$name}, $addonsign{$name}) + if $addonfile{$name} ne substr $addonsign{$name}, 0, -4; + } + + if ($self->{options}{no_overwrite_dir} and -e $newdirectory) { + error(g_('unpack target exists: %s'), $newdirectory); + } else { + erasedir($newdirectory); + } + + # Extract main tarball + info(g_('unpacking %s'), $tarfile); + my $tar = Dpkg::Source::Archive->new( + filename => File::Spec->catfile($self->{basedir}, $tarfile), + ); + $tar->extract($newdirectory, + options => [ '--anchored', '--no-wildcards-match-slash', + '--exclude', '*/.pc', '--exclude', '.pc' ]); + # The .pc exclusion is only needed for 3.0 (quilt) and to avoid + # having an upstream tarball provide a directory with symlinks + # that would be blindly followed when applying the patches + + # Extract additional orig tarballs + foreach my $subdir (sort keys %addonfile) { + my $file = $addonfile{$subdir}; + info(g_('unpacking %s'), $file); + + # If the pathname is an empty directory, just silently remove it, as + # it might be part of a git repository, as a submodule for example. + rmdir "$newdirectory/$subdir"; + if (-e "$newdirectory/$subdir") { + warning(g_("required removal of '%s' installed by original tarball"), + $subdir); + erasedir("$newdirectory/$subdir"); + } + $tar = Dpkg::Source::Archive->new( + filename => File::Spec->catfile($self->{basedir}, $file), + ); + $tar->extract("$newdirectory/$subdir"); + } + + # Stop here if debianization is not wanted + return if $self->{options}{skip_debianization}; + + # Extract debian tarball after removing the debian directory + info(g_('unpacking %s'), $debianfile); + erasedir("$newdirectory/debian"); + $tar = Dpkg::Source::Archive->new( + filename => File::Spec->catfile($self->{basedir}, $debianfile), + ); + $tar->extract($newdirectory, in_place => 1); + + # Apply patches (in a separate method as it might be overridden) + $self->apply_patches($newdirectory, usage => 'unpack') + unless $self->{options}{skip_patches}; +} + +sub get_autopatch_name { + return 'zz_debian-diff-auto'; +} + +sub _get_patches { + my ($self, $dir, %opts) = @_; + $opts{skip_auto} //= 0; + my @patches; + my $pd = "$dir/debian/patches"; + my $auto_patch = $self->get_autopatch_name(); + if (-d $pd) { + opendir(my $dir_dh, $pd) or syserr(g_('cannot opendir %s'), $pd); + foreach my $patch (sort readdir($dir_dh)) { + # patches match same rules as run-parts + next unless $patch =~ /^[\w-]+$/ and -f "$pd/$patch"; + next if $opts{skip_auto} and $patch eq $auto_patch; + push @patches, $patch; + } + closedir($dir_dh); + } + return @patches; +} + +sub apply_patches { + my ($self, $dir, %opts) = @_; + $opts{skip_auto} //= 0; + my @patches = $self->_get_patches($dir, %opts); + return unless scalar(@patches); + my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied'); + open(my $applied_fh, '>', $applied) + or syserr(g_('cannot write %s'), $applied); + print { $applied_fh } "# During $opts{usage}\n"; + my $timestamp = fs_time($applied); + foreach my $patch ($self->_get_patches($dir, %opts)) { + my $path = File::Spec->catfile($dir, 'debian', 'patches', $patch); + info(g_('applying %s'), $patch) unless $opts{skip_auto}; + my $patch_obj = Dpkg::Source::Patch->new(filename => $path); + $patch_obj->apply($dir, force_timestamp => 1, + timestamp => $timestamp, + add_options => [ '-E' ]); + print { $applied_fh } "$patch\n"; + } + close($applied_fh); +} + +sub unapply_patches { + my ($self, $dir, %opts) = @_; + my @patches = reverse($self->_get_patches($dir, %opts)); + return unless scalar(@patches); + my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied'); + my $timestamp = fs_time($applied); + foreach my $patch (@patches) { + my $path = File::Spec->catfile($dir, 'debian', 'patches', $patch); + info(g_('unapplying %s'), $patch) unless $opts{quiet}; + my $patch_obj = Dpkg::Source::Patch->new(filename => $path); + $patch_obj->apply($dir, force_timestamp => 1, verbose => 0, + timestamp => $timestamp, + add_options => [ '-E', '-R' ]); + } + unlink($applied); +} + +sub _upstream_tarball_template { + my $self = shift; + my $ext = '{' . join(',', + sort map { + compression_get_file_extension($_) + } compression_get_list()) . '}'; + return File::Spec->catfile('..', $self->get_basename() . ".orig.tar.$ext"); +} + +sub can_build { + my ($self, $dir) = @_; + return 1 if $self->find_original_tarballs(include_supplementary => 0); + return 1 if $self->{options}{create_empty_orig} and + $self->find_original_tarballs(include_main => 0); + return (0, sprintf(g_('no upstream tarball found at %s'), + $self->_upstream_tarball_template())); +} + +sub before_build { + my ($self, $dir) = @_; + $self->check_patches_applied($dir) if $self->{options}{preparation}; +} + +sub after_build { + my ($self, $dir) = @_; + my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied'); + my $reason = ''; + if (-e $applied) { + $reason = file_slurp($applied); + } + my $opt_unapply = $self->{options}{unapply_patches}; + if (($opt_unapply eq 'auto' and $reason =~ /^# During preparation/) or + $opt_unapply eq 'yes') { + $self->unapply_patches($dir); + } +} + +sub prepare_build { + my ($self, $dir) = @_; + $self->{diff_options} = { + diff_ignore_regex => $self->{options}{diff_ignore_regex} . + '|(^|/)debian/patches/.dpkg-source-applied$', + include_removal => $self->{options}{include_removal}, + include_timestamp => $self->{options}{include_timestamp}, + use_dev_null => 1, + }; + push @{$self->{options}{tar_ignore}}, 'debian/patches/.dpkg-source-applied'; + $self->check_patches_applied($dir) if $self->{options}{preparation}; + if ($self->{options}{create_empty_orig} and + not $self->find_original_tarballs(include_supplementary => 0)) + { + # No main orig.tar, create a dummy one + my $filename = $self->get_basename() . '.orig.tar.' . + $self->{options}{comp_ext}; + my $tar = Dpkg::Source::Archive->new(filename => $filename, + compression_level => $self->{options}{comp_level}); + $tar->create(); + $tar->finish(); + } +} + +sub check_patches_applied { + my ($self, $dir) = @_; + my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied'); + unless (-e $applied) { + info(g_('patches are not applied, applying them now')); + $self->apply_patches($dir, usage => 'preparation'); + } +} + +sub _generate_patch { + my ($self, $dir, %opts) = @_; + my ($dirname, $updir) = fileparse($dir); + my $basedirname = $self->get_basename(); + $basedirname =~ s/_/-/; + + # Identify original tarballs + my ($tarfile, %addonfile); + my $comp_ext_regex = compression_get_file_extension_regex(); + my @origtarfiles; + my @origtarsigns; + foreach my $file (sort $self->find_original_tarballs()) { + if ($file =~ /\.orig\.tar\.$comp_ext_regex$/) { + if (defined($tarfile)) { + error(g_('several orig.tar files found (%s and %s) but only ' . + 'one is allowed'), $tarfile, $file); + } + $tarfile = $file; + } elsif ($file =~ /\.orig-([[:alnum:]-]+)\.tar\.$comp_ext_regex$/) { + $addonfile{$1} = $file; + } else { + next; + } + + push @origtarfiles, $file; + $self->add_file($file); + + # Check for an upstream signature. + if (-e "$file.sig" and not -e "$file.asc") { + $self->armor_original_tarball_signature("$file.sig", "$file.asc"); + } + if (-e "$file.asc") { + push @origtarfiles, "$file.asc"; + push @origtarsigns, "$file.asc"; + $self->add_file("$file.asc") + } + } + + error(g_('no upstream tarball found at %s'), + $self->_upstream_tarball_template()) unless $tarfile; + + if ($opts{usage} eq 'build') { + if (@origtarsigns) { + $self->check_original_tarball_signature($dir, @origtarsigns); + } else { + my $key = $self->get_upstream_signing_key($dir); + if (-e $key) { + warning(g_('upstream signing key but no upstream tarball signature')); + } + } + + foreach my $origtarfile (@origtarfiles) { + info(g_('building %s using existing %s'), + $self->{fields}{'Source'}, $origtarfile); + } + } + + # Unpack a second copy for comparison + my $tmp = tempdir("$dirname.orig.XXXXXX", DIR => $updir); + push_exit_handler(sub { erasedir($tmp) }); + + # Extract main tarball + my $tar = Dpkg::Source::Archive->new(filename => $tarfile); + $tar->extract($tmp); + + # Extract additional orig tarballs + foreach my $subdir (keys %addonfile) { + my $file = $addonfile{$subdir}; + $tar = Dpkg::Source::Archive->new(filename => $file); + $tar->extract("$tmp/$subdir"); + } + + # Copy over the debian directory + erasedir("$tmp/debian"); + system('cp', '-a', '--', "$dir/debian", "$tmp/"); + subprocerr(g_('copy of the debian directory')) if $?; + + # Apply all patches except the last automatic one + $opts{skip_auto} //= 0; + $self->apply_patches($tmp, skip_auto => $opts{skip_auto}, usage => 'build'); + + # Create a patch + my ($difffh, $tmpdiff) = tempfile($self->get_basename(1) . '.diff.XXXXXX', + TMPDIR => 1, UNLINK => 0); + push_exit_handler(sub { unlink($tmpdiff) }); + my $diff = Dpkg::Source::Patch->new(filename => $tmpdiff, + compression => 'none'); + $diff->create(); + $diff->set_header(sub { + if ($opts{header_from} and -e $opts{header_from}) { + my $header_from = Dpkg::Source::Patch->new( + filename => $opts{header_from}); + my $analysis = $header_from->analyze($dir, verbose => 0); + return $analysis->{patchheader}; + } else { + return $self->_get_patch_header($dir); + } + }); + $diff->add_diff_directory($tmp, $dir, basedirname => $basedirname, + %{$self->{diff_options}}, + handle_binary_func => $opts{handle_binary}, + order_from => $opts{order_from}); + error(g_('unrepresentable changes to source')) if not $diff->finish(); + + if (-s $tmpdiff) { + info(g_('local changes detected, the modified files are:')); + my $analysis = $diff->analyze($dir, verbose => 0); + foreach my $fn (sort keys %{$analysis->{filepatched}}) { + print " $fn\n"; + } + } + + # Remove the temporary directory + erasedir($tmp); + pop_exit_handler(); + pop_exit_handler(); + + return $tmpdiff; +} + +sub do_build { + my ($self, $dir) = @_; + my @argv = @{$self->{options}{ARGV}}; + if (scalar(@argv)) { + usageerr(g_("-b takes only one parameter with format '%s'"), + $self->{fields}{'Format'}); + } + $self->prepare_build($dir); + + my $include_binaries = $self->{options}{include_binaries}; + my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}}; + + my $sourcepackage = $self->{fields}{'Source'}; + my $basenamerev = $self->get_basename(1); + + # Check if the debian directory contains unwanted binary files + my $binaryfiles = Dpkg::Source::BinaryFiles->new($dir); + + $binaryfiles->detect_binary_files( + exclude_globs => $self->{options}{tar_ignore}, + include_binaries => $include_binaries, + ); + + # Handle modified binary files detected by the auto-patch generation + my $handle_binary = sub { + my ($self, $old, $new, %opts) = @_; + + my $file = $opts{filename}; + $binaryfiles->new_binary_found($file); + unless ($include_binaries or $binaryfiles->binary_is_allowed($file)) { + errormsg(g_('cannot represent change to %s: %s'), $file, + g_('binary file contents changed')); + errormsg(g_('add %s in debian/source/include-binaries if you want ' . + 'to store the modified binary in the debian tarball'), + $file); + $self->register_error(); + } + }; + + # Create a patch + my $autopatch = File::Spec->catfile($dir, 'debian', 'patches', + $self->get_autopatch_name()); + my $tmpdiff = $self->_generate_patch($dir, order_from => $autopatch, + header_from => $autopatch, + handle_binary => $handle_binary, + skip_auto => $self->{options}{auto_commit}, + usage => 'build'); + unless (-z $tmpdiff or $self->{options}{auto_commit}) { + info(g_('Hint: make sure the version in debian/changelog matches ' . + 'the unpacked source tree')); + info(g_('you can integrate the local changes with %s'), + 'dpkg-source --commit'); + error(g_('aborting due to unexpected upstream changes, see %s'), + $tmpdiff); + } + push_exit_handler(sub { unlink($tmpdiff) }); + $binaryfiles->update_debian_source_include_binaries() if $include_binaries; + + # Install the diff as the new autopatch + if ($self->{options}{auto_commit}) { + make_path(File::Spec->catdir($dir, 'debian', 'patches')); + $autopatch = $self->register_patch($dir, $tmpdiff, + $self->get_autopatch_name()); + info(g_('local changes have been recorded in a new patch: %s'), + $autopatch) if -e $autopatch; + rmdir(File::Spec->catdir($dir, 'debian', 'patches')); # No check on purpose + } + unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff); + pop_exit_handler(); + + # Create the debian.tar + my $debianfile = "$basenamerev.debian.tar." . $self->{options}{comp_ext}; + info(g_('building %s in %s'), $sourcepackage, $debianfile); + my $tar = Dpkg::Source::Archive->new(filename => $debianfile, + compression_level => $self->{options}{comp_level}); + $tar->create(options => \@tar_ignore, chdir => $dir); + $tar->add_directory('debian'); + foreach my $binary ($binaryfiles->get_seen_binaries()) { + $tar->add_file($binary) unless $binary =~ m{^debian/}; + } + $tar->finish(); + + $self->add_file($debianfile); +} + +sub _get_patch_header { + my ($self, $dir) = @_; + + my $ph = File::Spec->catfile($dir, 'debian', 'source', 'local-patch-header'); + unless (-f $ph) { + $ph = File::Spec->catfile($dir, 'debian', 'source', 'patch-header'); + } + if (-f $ph) { + return file_slurp($ph); + } + + if ($self->{options}->{single_debian_patch}) { + return <<'AUTOGEN_HEADER'; +Description: Autogenerated patch header for a single-debian-patch file. + The delta against upstream is either kept as a single patch, or maintained + in some VCS, and exported as a single patch instead of more manageable + atomic patches. +Forwarded: not-needed + +--- +AUTOGEN_HEADER + } + + my $ch_info = changelog_parse(offset => 0, count => 1, + file => $self->{options}{changelog_file}); + return '' if not defined $ch_info; + my $header = Dpkg::Control->new(type => CTRL_UNKNOWN); + $header->{'Description'} = "<short summary of the patch>\n"; + $header->{'Description'} .= +"TODO: Put a short summary on the line above and replace this paragraph +with a longer explanation of this change. Complete the meta-information +with other relevant fields (see below for details). To make it easier, the +information below has been extracted from the changelog. Adjust it or drop +it.\n"; + $header->{'Description'} .= $ch_info->{'Changes'} . "\n"; + $header->{'Author'} = $ch_info->{'Maintainer'}; + my $yyyy_mm_dd = POSIX::strftime('%Y-%m-%d', gmtime); + + my $text; + $text = "$header"; + run_vendor_hook('extend-patch-header', \$text, $ch_info); + $text .= "\n--- +The information above should follow the Patch Tagging Guidelines, please +checkout https://dep.debian.net/deps/dep3/ to learn about the format. Here +are templates for supplementary fields that you might want to add: + +Origin: (upstream|backport|vendor|other), (<patch-url>|commit:<commit-id>) +Bug: <upstream-bugtracker-url> +Bug-Debian: https://bugs.debian.org/<bugnumber> +Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber> +Forwarded: (no|not-needed|<patch-forwarded-url>) +Applied-Upstream: <version>, (<commit-url>|commit:<commid-id>) +Reviewed-By: <name and email of someone who approved/reviewed the patch> +Last-Update: $yyyy_mm_dd\n\n"; + return $text; +} + +sub register_patch { + my ($self, $dir, $patch_file, $patch_name) = @_; + my $patch = File::Spec->catfile($dir, 'debian', 'patches', $patch_name); + if (-s $patch_file) { + copy($patch_file, $patch) + or syserr(g_('failed to copy %s to %s'), $patch_file, $patch); + chmod_if_needed(0666 & ~ umask(), $patch) + or syserr(g_("unable to change permission of '%s'"), $patch); + my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied'); + open(my $applied_fh, '>>', $applied) + or syserr(g_('cannot write %s'), $applied); + print { $applied_fh } "$patch\n"; + close($applied_fh) or syserr(g_('cannot close %s'), $applied); + } elsif (-e $patch) { + unlink($patch) or syserr(g_('cannot remove %s'), $patch); + } + return $patch; +} + +sub _is_bad_patch_name { + my ($dir, $patch_name) = @_; + + return 1 if not defined($patch_name); + return 1 if not length($patch_name); + + my $patch = File::Spec->catfile($dir, 'debian', 'patches', $patch_name); + if (-e $patch) { + warning(g_('cannot register changes in %s, this patch already exists'), + $patch); + return 1; + } + return 0; +} + +sub do_commit { + my ($self, $dir) = @_; + my ($patch_name, $tmpdiff) = @{$self->{options}{ARGV}}; + + $self->prepare_build($dir); + + # Try to fix up a broken relative filename for the patch + if ($tmpdiff and not -e $tmpdiff) { + $tmpdiff = File::Spec->catfile($dir, $tmpdiff) + unless File::Spec->file_name_is_absolute($tmpdiff); + error(g_("patch file '%s' doesn't exist"), $tmpdiff) if not -e $tmpdiff; + } + + my $binaryfiles = Dpkg::Source::BinaryFiles->new($dir); + my $handle_binary = sub { + my ($self, $old, $new, %opts) = @_; + my $fn = File::Spec->abs2rel($new, $dir); + $binaryfiles->new_binary_found($fn); + }; + + unless ($tmpdiff) { + $tmpdiff = $self->_generate_patch($dir, handle_binary => $handle_binary, + usage => 'commit'); + $binaryfiles->update_debian_source_include_binaries(); + } + push_exit_handler(sub { unlink($tmpdiff) }); + unless (-s $tmpdiff) { + unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff); + info(g_('there are no local changes to record')); + return; + } + while (_is_bad_patch_name($dir, $patch_name)) { + # Ask the patch name interactively + print g_('Enter the desired patch name: '); + $patch_name = <STDIN>; + if (not defined $patch_name) { + error(g_('no patch name given; cannot proceed')); + } + chomp $patch_name; + $patch_name =~ s/\s+/-/g; + $patch_name =~ s/\///g; + } + make_path(File::Spec->catdir($dir, 'debian', 'patches')); + my $patch = $self->register_patch($dir, $tmpdiff, $patch_name); + my @editors = ('sensible-editor', $ENV{VISUAL}, $ENV{EDITOR}, 'vi'); + my $editor = first { find_command($_) } @editors; + if (not $editor) { + error(g_('cannot find an editor')); + } + system($editor, $patch); + subprocerr($editor) if $?; + unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff); + pop_exit_handler(); + info(g_('local changes have been recorded in a new patch: %s'), $patch); +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Package/V3/Bzr.pm b/scripts/Dpkg/Source/Package/V3/Bzr.pm new file mode 100644 index 0000000..adc5fda --- /dev/null +++ b/scripts/Dpkg/Source/Package/V3/Bzr.pm @@ -0,0 +1,230 @@ +# Copyright © 2007 Colin Watson <cjwatson@debian.org>. +# Based on Dpkg::Source::Package::V3_0::git, which is: +# Copyright © 2007 Joey Hess <joeyh@debian.org>. +# Copyright © 2008 Frank Lichtenheld <djpig@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Package::V3::Bzr - class for source format 3.0 (bzr) + +=head1 DESCRIPTION + +This module provides a class to handle the source package format 3.0 (bzr). + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::Package::V3::Bzr 0.01; + +use strict; +use warnings; + +use Cwd; +use File::Basename; +use File::Spec; +use File::Find; +use File::Temp qw(tempdir); + +use Dpkg::Gettext; +use Dpkg::Compression; +use Dpkg::ErrorHandling; +use Dpkg::Source::Archive; +use Dpkg::Exit qw(push_exit_handler pop_exit_handler); +use Dpkg::Path qw(find_command); +use Dpkg::Source::Functions qw(erasedir); + +use parent qw(Dpkg::Source::Package); + +our $CURRENT_MINOR_VERSION = '0'; + +sub prerequisites { + return 1 if find_command('bzr'); + error(g_('cannot unpack bzr-format source package because ' . + 'bzr is not in the PATH')); +} + +sub _check_workdir { + my $srcdir = shift; + + if (! -d "$srcdir/.bzr") { + error(g_('source directory is not the top directory of a bzr repository (%s/.bzr not present), but Format bzr was specified'), + $srcdir); + } + + # Symlinks from .bzr to outside could cause unpack failures, or + # point to files they shouldn't, so check for and don't allow. + if (-l "$srcdir/.bzr") { + error(g_('%s is a symlink'), "$srcdir/.bzr"); + } + my $abs_srcdir = Cwd::abs_path($srcdir); + find(sub { + if (-l) { + if (Cwd::abs_path(readlink) !~ /^\Q$abs_srcdir\E(?:\/|$)/) { + error(g_('%s is a symlink to outside %s'), + $File::Find::name, $srcdir); + } + } + }, "$srcdir/.bzr"); + + return 1; +} + +sub can_build { + my ($self, $dir) = @_; + + return (0, g_("doesn't contain a bzr repository")) unless -d "$dir/.bzr"; + return 1; +} + +sub do_build { + my ($self, $dir) = @_; + my @argv = @{$self->{options}{ARGV}}; + # TODO: warn here? + #my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}}; + my $diff_ignore_regex = $self->{options}{diff_ignore_regex}; + + $dir =~ s{/+$}{}; # Strip trailing / + my ($dirname, $updir) = fileparse($dir); + + if (scalar(@argv)) { + usageerr(g_("-b takes only one parameter with format '%s'"), + $self->{fields}{'Format'}); + } + + my $sourcepackage = $self->{fields}{'Source'}; + my $basenamerev = $self->get_basename(1); + my $basename = $self->get_basename(); + my $basedirname = $basename; + $basedirname =~ s/_/-/; + + _check_workdir($dir); + + my $old_cwd = getcwd(); + chdir $dir or syserr(g_("unable to chdir to '%s'"), $dir); + + local $_; + + # Check for uncommitted files. + # To support dpkg-source -i, remove any ignored files from the + # output of bzr status. + open(my $bzr_status_fh, '-|', 'bzr', 'status') + or subprocerr('bzr status'); + my @files; + while (<$bzr_status_fh>) { + chomp; + next unless s/^ +//; + if (! length $diff_ignore_regex || + ! m/$diff_ignore_regex/o) { + push @files, $_; + } + } + close($bzr_status_fh) or syserr(g_('bzr status exited nonzero')); + if (@files) { + error(g_('uncommitted, not-ignored changes in working directory: %s'), + join(' ', @files)); + } + + chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd); + + my $tmp = tempdir("$dirname.bzr.XXXXXX", DIR => $updir); + push_exit_handler(sub { erasedir($tmp) }); + my $tardir = "$tmp/$dirname"; + + system('bzr', 'branch', $dir, $tardir); + subprocerr("bzr branch $dir $tardir") if $?; + + # Remove the working tree. + system('bzr', 'remove-tree', $tardir); + subprocerr("bzr remove-tree $tardir") if $?; + + # Some branch metadata files are unhelpful. + unlink("$tardir/.bzr/branch/branch-name", + "$tardir/.bzr/branch/parent"); + + # Create the tar file + my $debianfile = "$basenamerev.bzr.tar." . $self->{options}{comp_ext}; + info(g_('building %s in %s'), + $sourcepackage, $debianfile); + my $tar = Dpkg::Source::Archive->new(filename => $debianfile, + compression => $self->{options}{compression}, + compression_level => $self->{options}{comp_level}); + $tar->create(chdir => $tmp); + $tar->add_directory($dirname); + $tar->finish(); + + erasedir($tmp); + pop_exit_handler(); + + $self->add_file($debianfile); +} + +# Called after a tarball is unpacked, to check out the working copy. +sub do_extract { + my ($self, $newdirectory) = @_; + my $fields = $self->{fields}; + + my $basename = $self->get_basename(); + my $basenamerev = $self->get_basename(1); + + my @files = $self->get_files(); + if (@files > 1) { + error(g_('format v3.0 (bzr) uses only one source file')); + } + my $tarfile = $files[0]; + my $comp_ext_regex = compression_get_file_extension_regex(); + if ($tarfile !~ /^\Q$basenamerev\E\.bzr\.tar\.$comp_ext_regex$/) { + error(g_('expected %s, got %s'), + "$basenamerev.bzr.tar.$comp_ext_regex", $tarfile); + } + + if ($self->{options}{no_overwrite_dir} and -e $newdirectory) { + error(g_('unpack target exists: %s'), $newdirectory); + } else { + erasedir($newdirectory); + } + + # Extract main tarball + info(g_('unpacking %s'), $tarfile); + my $tar = Dpkg::Source::Archive->new( + filename => File::Spec->catfile($self->{basedir}, $tarfile), + ); + $tar->extract($newdirectory); + + _check_workdir($newdirectory); + + my $old_cwd = getcwd(); + chdir($newdirectory) + or syserr(g_("unable to chdir to '%s'"), $newdirectory); + + # Reconstitute the working tree. + system('bzr', 'checkout'); + subprocerr('bzr checkout') if $?; + + chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd); +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Package/V3/Custom.pm b/scripts/Dpkg/Source/Package/V3/Custom.pm new file mode 100644 index 0000000..5ef1e4f --- /dev/null +++ b/scripts/Dpkg/Source/Package/V3/Custom.pm @@ -0,0 +1,95 @@ +# Copyright © 2008 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Package::V3::Custom - class for source format 3.0 (custom) + +=head1 DESCRIPTION + +This module provides a class to handle the pseudo source package +format 3.0 (custom). + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::Package::V3::Custom 0.01; + +use strict; +use warnings; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +use parent qw(Dpkg::Source::Package); + +our $CURRENT_MINOR_VERSION = '0'; + +my @module_cmdline = ( + { + name => '--target-format=<value>', + help => N_('define the format of the generated source package'), + when => 'build', + } +); + +sub describe_cmdline_options { + return @module_cmdline; +} + +sub parse_cmdline_option { + my ($self, $opt) = @_; + if ($opt =~ /^--target-format=(.*)$/) { + $self->{options}{target_format} = $1; + return 1; + } + return 0; +} +sub do_extract { + error(g_("Format '3.0 (custom)' is only used to create source packages")); +} + +sub can_build { + my ($self, $dir) = @_; + + return (0, g_('no files indicated on command line')) + unless scalar(@{$self->{options}{ARGV}}); + return 1; +} + +sub do_build { + my ($self, $dir) = @_; + # Update real target format + my $format = $self->{options}{target_format}; + error(g_('--target-format option is missing')) unless $format; + $self->{fields}{'Format'} = $format; + # Add all files + foreach my $file (@{$self->{options}{ARGV}}) { + $self->add_file($file); + } +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Package/V3/Git.pm b/scripts/Dpkg/Source/Package/V3/Git.pm new file mode 100644 index 0000000..01f708d --- /dev/null +++ b/scripts/Dpkg/Source/Package/V3/Git.pm @@ -0,0 +1,300 @@ +# Copyright © 2007,2010 Joey Hess <joeyh@debian.org>. +# Copyright © 2008 Frank Lichtenheld <djpig@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Package::V3::Git - class for source format 3.0 (git) + +=head1 DESCRIPTION + +This module provides a class to handle the source package format 3.0 (git). + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::Package::V3::Git 0.02; + +use strict; +use warnings; + +use Cwd qw(abs_path getcwd); +use File::Basename; +use File::Spec; +use File::Temp qw(tempdir); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Exit qw(push_exit_handler pop_exit_handler); +use Dpkg::Path qw(find_command); +use Dpkg::Source::Functions qw(erasedir); + +use parent qw(Dpkg::Source::Package); + +our $CURRENT_MINOR_VERSION = '0'; + +# Remove variables from the environment that might cause git to do +# something unexpected. +delete $ENV{GIT_DIR}; +delete $ENV{GIT_INDEX_FILE}; +delete $ENV{GIT_OBJECT_DIRECTORY}; +delete $ENV{GIT_ALTERNATE_OBJECT_DIRECTORIES}; +delete $ENV{GIT_WORK_TREE}; + +sub prerequisites { + return 1 if find_command('git'); + error(g_('cannot unpack git-format source package because ' . + 'git is not in the PATH')); +} + +sub _check_workdir { + my $srcdir = shift; + + if (! -d "$srcdir/.git") { + error(g_('source directory is not the top directory of a git ' . + 'repository (%s/.git not present), but Format git was ' . + 'specified'), $srcdir); + } + if (-s "$srcdir/.gitmodules") { + error(g_('git repository %s uses submodules; this is not yet supported'), + $srcdir); + } + + return 1; +} + +sub _parse_vcs_git { + my $vcs_git = shift; + my ($url, $opt, $branch) = split ' ', $vcs_git; + + if (defined $opt && $opt eq '-b' && defined $branch) { + return ($url, $branch); + } else { + return ($url); + } +} + +my @module_cmdline = ( + { + name => '--git-ref=<ref>', + help => N_('specify a git <ref> to include in the git bundle'), + when => 'build', + }, { + name => '--git-depth=<number>', + help => N_('create a shallow clone with <number> depth'), + when => 'build', + } +); + +sub describe_cmdline_options { + my $self = shift; + + my @cmdline = ( $self->SUPER::describe_cmdline_options(), @module_cmdline ); + + return @cmdline; +} + +sub parse_cmdline_option { + my ($self, $opt) = @_; + return 1 if $self->SUPER::parse_cmdline_option($opt); + if ($opt =~ /^--git-ref=(.*)$/) { + push @{$self->{options}{git_ref}}, $1; + return 1; + } elsif ($opt =~ /^--git-depth=(\d+)$/) { + $self->{options}{git_depth} = $1; + return 1; + } + return 0; +} + +sub can_build { + my ($self, $dir) = @_; + + return (0, g_("doesn't contain a git repository")) unless -d "$dir/.git"; + return 1; +} + +sub do_build { + my ($self, $dir) = @_; + my $diff_ignore_regex = $self->{options}{diff_ignore_regex}; + + $dir =~ s{/+$}{}; # Strip trailing / + my ($dirname, $updir) = fileparse($dir); + my $basenamerev = $self->get_basename(1); + + _check_workdir($dir); + + my $old_cwd = getcwd(); + chdir $dir or syserr(g_("unable to chdir to '%s'"), $dir); + + # Check for uncommitted files. + # To support dpkg-source -i, get a list of files + # equivalent to the ones git status finds, and remove any + # ignored files from it. + my @ignores = '--exclude-per-directory=.gitignore'; + my $core_excludesfile = qx(git config --get core.excludesfile); + chomp $core_excludesfile; + if (length $core_excludesfile && -e $core_excludesfile) { + push @ignores, "--exclude-from=$core_excludesfile"; + } + if (-e '.git/info/exclude') { + push @ignores, '--exclude-from=.git/info/exclude'; + } + open(my $git_ls_files_fh, '-|', 'git', 'ls-files', '--modified', '--deleted', + '-z', '--others', @ignores) or subprocerr('git ls-files'); + my @files; + { + local $_; + local $/ = "\0"; + while (<$git_ls_files_fh>) { + chomp; + if (! length $diff_ignore_regex || + ! m/$diff_ignore_regex/o) { + push @files, $_; + } + } + } + close($git_ls_files_fh) or syserr(g_('git ls-files exited nonzero')); + if (@files) { + error(g_('uncommitted, not-ignored changes in working directory: %s'), + join(' ', @files)); + } + + # If a depth was specified, need to create a shallow clone and + # bundle that. + my $tmp; + my $shallowfile; + if ($self->{options}{git_depth}) { + chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd); + $tmp = tempdir("$dirname.git.XXXXXX", DIR => $updir); + push_exit_handler(sub { erasedir($tmp) }); + my $clone_dir = "$tmp/repo.git"; + # file:// is needed to avoid local cloning, which does not + # create a shallow clone. + info(g_('creating shallow clone with depth %s'), + $self->{options}{git_depth}); + system('git', 'clone', '--depth=' . $self->{options}{git_depth}, + '--quiet', '--bare', 'file://' . abs_path($dir), $clone_dir); + subprocerr('git clone') if $?; + chdir($clone_dir) + or syserr(g_("unable to chdir to '%s'"), $clone_dir); + $shallowfile = "$basenamerev.gitshallow"; + system('cp', '-f', 'shallow', "$old_cwd/$shallowfile"); + subprocerr('cp shallow') if $?; + } + + # Create the git bundle. + my $bundlefile = "$basenamerev.git"; + my @bundle_arg = $self->{options}{git_ref} ? + (@{$self->{options}{git_ref}}) : '--all'; + info(g_('bundling: %s'), join(' ', @bundle_arg)); + system('git', 'bundle', 'create', "$old_cwd/$bundlefile", + @bundle_arg, + 'HEAD', # ensure HEAD is included no matter what + '--', # avoids ambiguity error when referring to eg, a debian branch + ); + subprocerr('git bundle') if $?; + + chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd); + + if (defined $tmp) { + erasedir($tmp); + pop_exit_handler(); + } + + $self->add_file($bundlefile); + if (defined $shallowfile) { + $self->add_file($shallowfile); + } +} + +sub do_extract { + my ($self, $newdirectory) = @_; + my $fields = $self->{fields}; + + my $basenamerev = $self->get_basename(1); + + my @files = $self->get_files(); + my ($bundle, $shallow); + foreach my $file (@files) { + if ($file =~ /^\Q$basenamerev\E\.git$/) { + if (! defined $bundle) { + $bundle = $file; + } else { + error(g_('format v3.0 (git) uses only one .git file')); + } + } elsif ($file =~ /^\Q$basenamerev\E\.gitshallow$/) { + if (! defined $shallow) { + $shallow = $file; + } else { + error(g_('format v3.0 (git) uses only one .gitshallow file')); + } + } else { + error(g_('format v3.0 (git) unknown file: %s'), $file); + } + } + if (! defined $bundle) { + error(g_('format v3.0 (git) expected %s'), "$basenamerev.git"); + } + + if ($self->{options}{no_overwrite_dir} and -e $newdirectory) { + error(g_('unpack target exists: %s'), $newdirectory); + } else { + erasedir($newdirectory); + } + + # Extract git bundle. + info(g_('cloning %s'), $bundle); + my $bundle_path = File::Spec->catfile($self->{basedir}, $bundle); + system('git', 'clone', '--quiet', '--origin=bundle', $bundle_path, $newdirectory); + subprocerr('git bundle') if $?; + + if (defined $shallow) { + # Move shallow info file into place, so git does not + # try to follow parents of shallow refs. + info(g_('setting up shallow clone')); + my $shallow_orig = File::Spec->catfile($self->{basedir}, $shallow); + my $shallow_dest = File::Spec->catfile($newdirectory, '.git', 'shallow'); + system('cp', '-f', $shallow_orig, $shallow_dest); + subprocerr('cp') if $?; + } + + _check_workdir($newdirectory); + + if (defined $fields->{'Vcs-Git'}) { + my $remote = 'origin'; + my ($url, $head) = _parse_vcs_git($fields->{'Vcs-Git'}); + + my @git_remote_add = (qw(git -C), $newdirectory, qw(remote add)); + push @git_remote_add, '-m', $head if defined $head; + + info(g_('setting remote %s to %s'), $remote, $url); + system(@git_remote_add, $remote, $url); + subprocerr('git remote add') if $?; + } +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Package/V3/Native.pm b/scripts/Dpkg/Source/Package/V3/Native.pm new file mode 100644 index 0000000..80debf5 --- /dev/null +++ b/scripts/Dpkg/Source/Package/V3/Native.pm @@ -0,0 +1,141 @@ +# Copyright © 2008 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Package::V3::Native - class for source format 3.0 (native) + +=head1 DESCRIPTION + +This module provides a class to handle the source package format 3.0 (native). + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::Package::V3::Native 0.01; + +use strict; +use warnings; + +use Cwd; +use File::Basename; +use File::Spec; +use File::Temp qw(tempfile); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Compression; +use Dpkg::Exit qw(push_exit_handler pop_exit_handler); +use Dpkg::Version; +use Dpkg::Source::Archive; +use Dpkg::Source::Functions qw(erasedir); + +use parent qw(Dpkg::Source::Package); + +our $CURRENT_MINOR_VERSION = '0'; + +sub do_extract { + my ($self, $newdirectory) = @_; + my $sourcestyle = $self->{options}{sourcestyle}; + my $fields = $self->{fields}; + + my $basename = $self->get_basename(); + my $basenamerev = $self->get_basename(1); + + my $tarfile; + my $comp_ext_regex = compression_get_file_extension_regex(); + foreach my $file ($self->get_files()) { + if ($file =~ /^\Q$basenamerev\E\.tar\.$comp_ext_regex$/) { + error(g_('multiple tarfiles in native source package')) if $tarfile; + $tarfile = $file; + } else { + error(g_('unrecognized file for a native source package: %s'), $file); + } + } + + error(g_('no tarfile in Files field')) unless $tarfile; + + if ($self->{options}{no_overwrite_dir} and -e $newdirectory) { + error(g_('unpack target exists: %s'), $newdirectory); + } else { + erasedir($newdirectory); + } + + info(g_('unpacking %s'), $tarfile); + my $tar = Dpkg::Source::Archive->new( + filename => File::Spec->catfile($self->{basedir}, $tarfile), + ); + $tar->extract($newdirectory); +} + +sub can_build { + my ($self, $dir) = @_; + + my $v = Dpkg::Version->new($self->{fields}->{'Version'}); + return (0, g_('native package version may not have a revision')) + unless $v->is_native(); + + return 1; +} + +sub do_build { + my ($self, $dir) = @_; + my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}}; + my @argv = @{$self->{options}{ARGV}}; + + if (scalar(@argv)) { + usageerr(g_("-b takes only one parameter with format '%s'"), + $self->{fields}{'Format'}); + } + + my $sourcepackage = $self->{fields}{'Source'}; + my $basenamerev = $self->get_basename(1); + my $tarname = "$basenamerev.tar." . $self->{options}{comp_ext}; + + info(g_('building %s in %s'), $sourcepackage, $tarname); + + my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX", + DIR => getcwd(), UNLINK => 0); + push_exit_handler(sub { unlink($newtar) }); + + my ($dirname, $dirbase) = fileparse($dir); + my $tar = Dpkg::Source::Archive->new(filename => $newtar, + compression => compression_guess_from_filename($tarname), + compression_level => $self->{options}{comp_level}); + $tar->create(options => \@tar_ignore, chdir => $dirbase); + $tar->add_directory($dirname); + $tar->finish(); + rename($newtar, $tarname) + or syserr(g_("unable to rename '%s' (newly created) to '%s'"), + $newtar, $tarname); + pop_exit_handler(); + chmod(0666 &~ umask(), $tarname) + or syserr(g_("unable to change permission of '%s'"), $tarname); + + $self->add_file($tarname); +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Package/V3/Quilt.pm b/scripts/Dpkg/Source/Package/V3/Quilt.pm new file mode 100644 index 0000000..663d021 --- /dev/null +++ b/scripts/Dpkg/Source/Package/V3/Quilt.pm @@ -0,0 +1,289 @@ +# Copyright © 2008-2012 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Package::V3::Quilt - class for source format 3.0 (quilt) + +=head1 DESCRIPTION + +This module provides a class to handle the source package format 3.0 (quilt). + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::Package::V3::Quilt 0.01; + +use strict; +use warnings; + +use List::Util qw(any); +use File::Spec; +use File::Copy; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::File; +use Dpkg::Version; +use Dpkg::Source::Patch; +use Dpkg::Source::Functions qw(erasedir chmod_if_needed fs_time); +use Dpkg::Source::Quilt; +use Dpkg::Exit; + +# Based on wig&pen implementation +use parent qw(Dpkg::Source::Package::V2); + +our $CURRENT_MINOR_VERSION = '0'; + +sub init_options { + my $self = shift; + $self->{options}{single_debian_patch} //= 0; + $self->{options}{allow_version_of_quilt_db} //= []; + + $self->SUPER::init_options(); +} + +my @module_cmdline = ( + { + name => '--single-debian-patch', + help => N_('use a single debianization patch'), + when => 'build', + }, { + name => '--allow-version-of-quilt-db=<version>', + help => N_('accept quilt metadata <version> even if unknown'), + when => 'build', + } +); + +sub describe_cmdline_options { + my $self = shift; + + my @cmdline = ( $self->SUPER::describe_cmdline_options(), @module_cmdline ); + + return @cmdline; +} + +sub parse_cmdline_option { + my ($self, $opt) = @_; + return 1 if $self->SUPER::parse_cmdline_option($opt); + if ($opt eq '--single-debian-patch') { + $self->{options}{single_debian_patch} = 1; + # For backwards compatibility. + $self->{options}{auto_commit} = 1; + return 1; + } elsif ($opt =~ /^--allow-version-of-quilt-db=(.*)$/) { + push @{$self->{options}{allow_version_of_quilt_db}}, $1; + return 1; + } + return 0; +} + +sub _build_quilt_object { + my ($self, $dir) = @_; + return $self->{quilt}{$dir} if exists $self->{quilt}{$dir}; + $self->{quilt}{$dir} = Dpkg::Source::Quilt->new($dir); + return $self->{quilt}{$dir}; +} + +sub can_build { + my ($self, $dir) = @_; + my ($code, $msg) = $self->SUPER::can_build($dir); + return ($code, $msg) if $code == 0; + + my $v = Dpkg::Version->new($self->{fields}->{'Version'}); + return (0, g_('non-native package version does not contain a revision')) + if $v->is_native(); + + my $quilt = $self->_build_quilt_object($dir); + $msg = $quilt->find_problems(); + return (0, $msg) if $msg; + return 1; +} + +sub get_autopatch_name { + my $self = shift; + if ($self->{options}{single_debian_patch}) { + return 'debian-changes'; + } else { + return 'debian-changes-' . $self->{fields}{'Version'}; + } +} + +sub apply_patches { + my ($self, $dir, %opts) = @_; + + if ($opts{usage} eq 'unpack') { + $opts{verbose} = 1; + } elsif ($opts{usage} eq 'build') { + $opts{warn_options} = 1; + $opts{verbose} = 0; + } + + my $quilt = $self->_build_quilt_object($dir); + $quilt->load_series(%opts) if $opts{warn_options}; # Trigger warnings + + # Always create the quilt db so that if the maintainer calls quilt to + # create a patch, it's stored in the right directory + $quilt->save_db(); + + # Update debian/patches/series symlink if needed to allow quilt usage + my $series = $quilt->get_series_file(); + my $basename = (File::Spec->splitpath($series))[2]; + if ($basename ne 'series') { + my $dest = $quilt->get_patch_file('series'); + unlink($dest) if -l $dest; + unless (-f _) { # Don't overwrite real files + symlink($basename, $dest) + or syserr(g_("can't create symlink %s"), $dest); + } + } + + return unless scalar($quilt->series()); + + info(g_('using patch list from %s'), "debian/patches/$basename"); + + if ($opts{usage} eq 'preparation' and + $self->{options}{unapply_patches} eq 'auto') { + # We're applying the patches in --before-build, remember to unapply + # them afterwards in --after-build + my $pc_unapply = $quilt->get_db_file('.dpkg-source-unapply'); + file_touch($pc_unapply); + } + + # Apply patches + my $pc_applied = $quilt->get_db_file('applied-patches'); + $opts{timestamp} = fs_time($pc_applied); + if ($opts{skip_auto}) { + my $auto_patch = $self->get_autopatch_name(); + $quilt->push(%opts) while ($quilt->next() and $quilt->next() ne $auto_patch); + } else { + $quilt->push(%opts) while $quilt->next(); + } +} + +sub unapply_patches { + my ($self, $dir, %opts) = @_; + + my $quilt = $self->_build_quilt_object($dir); + + $opts{verbose} //= 1; + + my $pc_applied = $quilt->get_db_file('applied-patches'); + my @applied = $quilt->applied(); + $opts{timestamp} = fs_time($pc_applied) if @applied; + + $quilt->pop(%opts) while $quilt->top(); + + erasedir($quilt->get_db_dir()); +} + +sub prepare_build { + my ($self, $dir) = @_; + $self->SUPER::prepare_build($dir); + # Skip .pc directories of quilt by default and ignore difference + # on debian/patches/series symlinks and d/p/.dpkg-source-applied + # stamp file created by ourselves + my $func = sub { + my $pathname = shift; + + return 1 if $pathname eq 'debian/patches/series' and -l $pathname; + return 1 if $pathname =~ /^\.pc(\/|$)/; + return 1 if $pathname =~ /$self->{options}{diff_ignore_regex}/; + return 0; + }; + $self->{diff_options}{diff_ignore_func} = $func; +} + +sub do_build { + my ($self, $dir) = @_; + + my $quilt = $self->_build_quilt_object($dir); + my $version = $quilt->get_db_version(); + + if (defined($version) and $version != 2) { + if (any { $version eq $_ } + @{$self->{options}{allow_version_of_quilt_db}}) + { + warning(g_('unsupported version of the quilt metadata: %s'), $version); + } else { + error(g_('unsupported version of the quilt metadata: %s'), $version); + } + } + + $self->SUPER::do_build($dir); +} + +sub after_build { + my ($self, $dir) = @_; + my $quilt = $self->_build_quilt_object($dir); + my $pc_unapply = $quilt->get_db_file('.dpkg-source-unapply'); + my $opt_unapply = $self->{options}{unapply_patches}; + if (($opt_unapply eq 'auto' and -e $pc_unapply) or $opt_unapply eq 'yes') { + unlink($pc_unapply); + $self->unapply_patches($dir); + } +} + +sub check_patches_applied { + my ($self, $dir) = @_; + + my $quilt = $self->_build_quilt_object($dir); + my $next = $quilt->next(); + return if not defined $next; + + my $first_patch = File::Spec->catfile($dir, 'debian', 'patches', $next); + my $patch_obj = Dpkg::Source::Patch->new(filename => $first_patch); + return unless $patch_obj->check_apply($dir, fatal_dupes => 1); + + $self->apply_patches($dir, usage => 'preparation', verbose => 1); +} + +sub register_patch { + my ($self, $dir, $tmpdiff, $patch_name) = @_; + + my $quilt = $self->_build_quilt_object($dir); + my $patch = $quilt->get_patch_file($patch_name); + + if (-s $tmpdiff) { + copy($tmpdiff, $patch) + or syserr(g_('failed to copy %s to %s'), $tmpdiff, $patch); + chmod_if_needed(0666 & ~ umask(), $patch) + or syserr(g_("unable to change permission of '%s'"), $patch); + } elsif (-e $patch) { + unlink($patch) or syserr(g_('cannot remove %s'), $patch); + } + + if (-e $patch) { + # Add patch to series file + $quilt->register($patch_name); + } else { + # Remove auto_patch from series + $quilt->unregister($patch_name); + } + return $patch; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Patch.pm b/scripts/Dpkg/Source/Patch.pm new file mode 100644 index 0000000..57468fc --- /dev/null +++ b/scripts/Dpkg/Source/Patch.pm @@ -0,0 +1,725 @@ +# Copyright © 2008 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2010, 2012-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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Patch - represent a patch file + +=head1 DESCRIPTION + +This module provides a class to handle patch files. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::Patch 0.01; + +use strict; +use warnings; + +use POSIX qw(:errno_h :sys_wait_h); +use File::Find; +use File::Basename; +use File::Spec; +use File::Path qw(make_path); +use File::Compare; +use Fcntl qw(:mode); +use Time::HiRes qw(stat); + +use Dpkg; +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::IPC; +use Dpkg::Source::Functions qw(fs_time); + +use parent qw(Dpkg::Compression::FileHandle); + +sub create { + my ($self, %opts) = @_; + $self->ensure_open('w'); # Creates the file + *$self->{errors} = 0; + *$self->{empty} = 1; + if ($opts{old} and $opts{new} and $opts{filename}) { + $opts{old} = '/dev/null' unless -e $opts{old}; + $opts{new} = '/dev/null' unless -e $opts{new}; + if (-d $opts{old} and -d $opts{new}) { + $self->add_diff_directory($opts{old}, $opts{new}, %opts); + } elsif (-f $opts{old} and -f $opts{new}) { + $self->add_diff_file($opts{old}, $opts{new}, %opts); + } else { + $self->_fail_not_same_type($opts{old}, $opts{new}, $opts{filename}); + } + $self->finish() unless $opts{nofinish}; + } +} + +sub set_header { + my ($self, $header) = @_; + *$self->{header} = $header; +} + +sub get_header { + my $self = shift; + + if (ref *$self->{header} eq 'CODE') { + return *$self->{header}->(); + } else { + return *$self->{header}; + } +} + +sub add_diff_file { + my ($self, $old, $new, %opts) = @_; + $opts{include_timestamp} //= 0; + my $handle_binary = $opts{handle_binary_func} // sub { + my ($self, $old, $new, %opts) = @_; + my $file = $opts{filename}; + $self->_fail_with_msg($file, g_('binary file contents changed')); + }; + # Optimization to avoid forking diff if unnecessary + return 1 if compare($old, $new, 4096) == 0; + # Default diff options + my @options; + if ($opts{options}) { + push @options, @{$opts{options}}; + } else { + push @options, '-p'; + } + # Add labels + if ($opts{label_old} and $opts{label_new}) { + if ($opts{include_timestamp}) { + my $ts = (stat($old))[9]; + my $t = POSIX::strftime('%Y-%m-%d %H:%M:%S', gmtime($ts)); + $opts{label_old} .= sprintf("\t%s.%09d +0000", $t, + ($ts - int($ts)) * 1_000_000_000); + $ts = (stat($new))[9]; + $t = POSIX::strftime('%Y-%m-%d %H:%M:%S', gmtime($ts)); + $opts{label_new} .= sprintf("\t%s.%09d +0000", $t, + ($ts - int($ts)) * 1_000_000_000); + } else { + # Space in filenames need special treatment + $opts{label_old} .= "\t" if $opts{label_old} =~ / /; + $opts{label_new} .= "\t" if $opts{label_new} =~ / /; + } + push @options, '-L', $opts{label_old}, + '-L', $opts{label_new}; + } + # Generate diff + my $diffgen; + my $diff_pid = spawn( + exec => [ 'diff', '-u', @options, '--', $old, $new ], + env => { LC_ALL => 'C', TZ => 'UTC0' }, + to_pipe => \$diffgen, + ); + # Check diff and write it in patch file + my $difflinefound = 0; + my $binary = 0; + local $_; + + while (<$diffgen>) { + if (m/^(?:binary|[^-+\@ ].*\bdiffer\b)/i) { + $binary = 1; + $handle_binary->($self, $old, $new, %opts); + last; + } elsif (m/^[-+\@ ]/) { + $difflinefound++; + } elsif (m/^\\ /) { + warning(g_('file %s has no final newline (either ' . + 'original or modified version)'), $new); + } else { + chomp; + error(g_("unknown line from diff -u on %s: '%s'"), $new, $_); + } + if (*$self->{empty} and defined(*$self->{header})) { + $self->print($self->get_header()) or syserr(g_('failed to write')); + *$self->{empty} = 0; + } + print { $self } $_ or syserr(g_('failed to write')); + } + close($diffgen) or syserr('close on diff pipe'); + wait_child($diff_pid, nocheck => 1, + cmdline => "diff -u @options -- $old $new"); + # Verify diff process ended successfully + # Exit code of diff: 0 => no difference, 1 => diff ok, 2 => error + # Ignore error if binary content detected + my $exit = WEXITSTATUS($?); + unless (WIFEXITED($?) && ($exit == 0 || $exit == 1 || $binary)) { + subprocerr(g_('diff on %s'), $new); + } + return ($exit == 0 || $exit == 1); +} + +sub add_diff_directory { + my ($self, $old, $new, %opts) = @_; + # TODO: make this function more configurable + # - offer to disable some checks + my $basedir = $opts{basedirname} || basename($new); + my $diff_ignore; + if ($opts{diff_ignore_func}) { + $diff_ignore = $opts{diff_ignore_func}; + } elsif ($opts{diff_ignore_regex}) { + $diff_ignore = sub { return $_[0] =~ /$opts{diff_ignore_regex}/o }; + } else { + $diff_ignore = sub { return 0 }; + } + + my @diff_files; + my %files_in_new; + my $scan_new = sub { + my $fn = (length > length($new)) ? substr($_, length($new) + 1) : '.'; + return if $diff_ignore->($fn); + $files_in_new{$fn} = 1; + lstat("$new/$fn") or syserr(g_('cannot stat file %s'), "$new/$fn"); + my $mode = S_IMODE((lstat(_))[2]); + my $size = (lstat(_))[7]; + if (-l _) { + unless (-l "$old/$fn") { + $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); + return; + } + my $n = readlink("$new/$fn"); + unless (defined $n) { + syserr(g_('cannot read link %s'), "$new/$fn"); + } + my $n2 = readlink("$old/$fn"); + unless (defined $n2) { + syserr(g_('cannot read link %s'), "$old/$fn"); + } + unless ($n eq $n2) { + $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); + } + } elsif (-f _) { + my $old_file = "$old/$fn"; + if (not lstat("$old/$fn")) { + if ($! != ENOENT) { + syserr(g_('cannot stat file %s'), "$old/$fn"); + } + $old_file = '/dev/null'; + } elsif (not -f _) { + $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); + return; + } + + my $label_old = "$basedir.orig/$fn"; + if ($opts{use_dev_null}) { + $label_old = $old_file if $old_file eq '/dev/null'; + } + push @diff_files, [$fn, $mode, $size, $old_file, "$new/$fn", + $label_old, "$basedir/$fn"]; + } elsif (-p _) { + unless (-p "$old/$fn") { + $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); + } + } elsif (-b _ || -c _ || -S _) { + $self->_fail_with_msg("$new/$fn", + g_('device or socket is not allowed')); + } elsif (-d _) { + if (not lstat("$old/$fn")) { + if ($! != ENOENT) { + syserr(g_('cannot stat file %s'), "$old/$fn"); + } + } elsif (not -d _) { + $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); + } + } else { + $self->_fail_with_msg("$new/$fn", g_('unknown file type')); + } + }; + my $scan_old = sub { + my $fn = (length > length($old)) ? substr($_, length($old) + 1) : '.'; + return if $diff_ignore->($fn); + return if $files_in_new{$fn}; + lstat("$old/$fn") or syserr(g_('cannot stat file %s'), "$old/$fn"); + if (-f _) { + if (not defined $opts{include_removal}) { + warning(g_('ignoring deletion of file %s'), $fn); + } elsif (not $opts{include_removal}) { + warning(g_('ignoring deletion of file %s, use --include-removal to override'), $fn); + } else { + push @diff_files, [$fn, 0, 0, "$old/$fn", '/dev/null', + "$basedir.orig/$fn", '/dev/null']; + } + } elsif (-d _) { + warning(g_('ignoring deletion of directory %s'), $fn); + } elsif (-l _) { + warning(g_('ignoring deletion of symlink %s'), $fn); + } else { + $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); + } + }; + + find({ wanted => $scan_new, no_chdir => 1 }, $new); + find({ wanted => $scan_old, no_chdir => 1 }, $old); + + if ($opts{order_from} and -e $opts{order_from}) { + my $order_from = Dpkg::Source::Patch->new( + filename => $opts{order_from}); + my $analysis = $order_from->analyze($basedir, verbose => 0); + my %patchorder; + my $i = 0; + foreach my $fn (@{$analysis->{patchorder}}) { + $fn =~ s{^[^/]+/}{}; + $patchorder{$fn} = $i++; + } + # 'quilt refresh' sorts files as follows: + # - Any files in the existing patch come first, in the order in + # which they appear in the existing patch. + # - New files follow, sorted lexicographically. + # This seems a reasonable policy to follow, and avoids autopatches + # being shuffled when they are regenerated. + foreach my $diff_file (sort { $a->[0] cmp $b->[0] } @diff_files) { + my $fn = $diff_file->[0]; + $patchorder{$fn} //= $i++; + } + @diff_files = sort { $patchorder{$a->[0]} <=> $patchorder{$b->[0]} } + @diff_files; + } else { + @diff_files = sort { $a->[0] cmp $b->[0] } @diff_files; + } + + foreach my $diff_file (@diff_files) { + my ($fn, $mode, $size, + $old_file, $new_file, $label_old, $label_new) = @$diff_file; + my $success = $self->add_diff_file($old_file, $new_file, + filename => $fn, + label_old => $label_old, + label_new => $label_new, %opts); + if ($success and + $old_file eq '/dev/null' and $new_file ne '/dev/null') { + if (not $size) { + warning(g_("newly created empty file '%s' will not " . + 'be represented in diff'), $fn); + } else { + if ($mode & (S_IXUSR | S_IXGRP | S_IXOTH)) { + warning(g_("executable mode %04o of '%s' will " . + 'not be represented in diff'), $mode, $fn) + unless $fn eq 'debian/rules'; + } + if ($mode & (S_ISUID | S_ISGID | S_ISVTX)) { + warning(g_("special mode %04o of '%s' will not " . + 'be represented in diff'), $mode, $fn); + } + } + } + } +} + +sub finish { + my $self = shift; + close($self) or syserr(g_('cannot close %s'), $self->get_filename()); + return not *$self->{errors}; +} + +sub register_error { + my $self = shift; + *$self->{errors}++; +} +sub _fail_with_msg { + my ($self, $file, $msg) = @_; + errormsg(g_('cannot represent change to %s: %s'), $file, $msg); + $self->register_error(); +} +sub _fail_not_same_type { + my ($self, $old, $new, $file) = @_; + my $old_type = get_type($old); + my $new_type = get_type($new); + errormsg(g_('cannot represent change to %s:'), $file); + errormsg(g_(' new version is %s'), $new_type); + errormsg(g_(' old version is %s'), $old_type); + $self->register_error(); +} + +sub _getline { + my $handle = shift; + + my $line = <$handle>; + if (defined $line) { + # Strip end-of-line chars + chomp($line); + $line =~ s/\r$//; + } + return $line; +} + +# Fetch the header filename ignoring the optional timestamp +sub _fetch_filename { + my ($diff, $header) = @_; + + # Strip any leading spaces. + $header =~ s/^\s+//; + + # Is it a C-style string? + if ($header =~ m/^"/) { + error(g_('diff %s patches file with C-style encoded filename'), $diff); + } else { + # Tab is the official separator, it's always used when + # filename contain spaces. Try it first, otherwise strip on space + # if there's no tab + $header =~ s/\s.*// unless $header =~ s/\t.*//; + } + + return $header; +} + +sub _intuit_file_patched { + my ($old, $new) = @_; + + return $new unless defined $old; + return $old unless defined $new; + return $new if -e $new and not -e $old; + return $old if -e $old and not -e $new; + + # We don't consider the case where both files are non-existent and + # where patch picks the one with the fewest directories to create + # since dpkg-source will pre-create the required directories + + # Precalculate metrics used by patch + my ($tmp_o, $tmp_n) = ($old, $new); + my ($len_o, $len_n) = (length($old), length($new)); + $tmp_o =~ s{[/\\]+}{/}g; + $tmp_n =~ s{[/\\]+}{/}g; + my $nb_comp_o = ($tmp_o =~ tr{/}{/}); + my $nb_comp_n = ($tmp_n =~ tr{/}{/}); + $tmp_o =~ s{^.*/}{}; + $tmp_n =~ s{^.*/}{}; + my ($blen_o, $blen_n) = (length($tmp_o), length($tmp_n)); + + # Decide like patch would + if ($nb_comp_o != $nb_comp_n) { + return ($nb_comp_o < $nb_comp_n) ? $old : $new; + } elsif ($blen_o != $blen_n) { + return ($blen_o < $blen_n) ? $old : $new; + } elsif ($len_o != $len_n) { + return ($len_o < $len_n) ? $old : $new; + } + return $old; +} + +# check diff for sanity, find directories to create as a side effect +sub analyze { + my ($self, $destdir, %opts) = @_; + + $opts{verbose} //= 1; + my $diff = $self->get_filename(); + my %filepatched; + my %dirtocreate; + my @patchorder; + my $patch_header = ''; + my $diff_count = 0; + + my $line = _getline($self); + + HUNK: + while (defined $line or not eof $self) { + my (%path, %fn); + + # Skip comments leading up to the patch (if any). Although we do not + # look for an Index: pseudo-header in the comments, because we would + # not use it anyway, as we require both ---/+++ filename headers. + while (1) { + if ($line =~ /^(?:--- |\+\+\+ |@@ -)/) { + last; + } else { + $patch_header .= "$line\n"; + } + $line = _getline($self); + last HUNK if not defined $line; + } + $diff_count++; + # read file header (---/+++ pair) + unless ($line =~ s/^--- //) { + error(g_("expected ^--- in line %d of diff '%s'"), $., $diff); + } + $path{old} = $line = _fetch_filename($diff, $line); + if ($line ne '/dev/null' and $line =~ s{^[^/]*/+}{$destdir/}) { + $fn{old} = $line; + } + if ($line =~ /\.dpkg-orig$/) { + error(g_("diff '%s' patches file with name ending in .dpkg-orig"), + $diff); + } + + $line = _getline($self); + unless (defined $line) { + error(g_("diff '%s' finishes in middle of ---/+++ (line %d)"), + $diff, $.); + } + unless ($line =~ s/^\+\+\+ //) { + error(g_("line after --- isn't as expected in diff '%s' (line %d)"), + $diff, $.); + } + $path{new} = $line = _fetch_filename($diff, $line); + if ($line ne '/dev/null' and $line =~ s{^[^/]*/+}{$destdir/}) { + $fn{new} = $line; + } + + unless (defined $fn{old} or defined $fn{new}) { + error(g_("none of the filenames in ---/+++ are valid in diff '%s' (line %d)"), + $diff, $.); + } + + # Safety checks on both filenames that patch could use + foreach my $key ('old', 'new') { + next unless defined $fn{$key}; + if ($path{$key} =~ m{/\.\./}) { + error(g_('%s contains an insecure path: %s'), $diff, $path{$key}); + } + my $path = $fn{$key}; + while (1) { + if (-l $path) { + error(g_('diff %s modifies file %s through a symlink: %s'), + $diff, $fn{$key}, $path); + } + last unless $path =~ s{/+[^/]*$}{}; + last if length($path) <= length($destdir); # $destdir is assumed safe + } + } + + if ($path{old} eq '/dev/null' and $path{new} eq '/dev/null') { + error(g_("original and modified files are /dev/null in diff '%s' (line %d)"), + $diff, $.); + } elsif ($path{new} eq '/dev/null') { + error(g_("file removal without proper filename in diff '%s' (line %d)"), + $diff, $. - 1) unless defined $fn{old}; + if ($opts{verbose}) { + warning(g_('diff %s removes a non-existing file %s (line %d)'), + $diff, $fn{old}, $.) unless -e $fn{old}; + } + } + my $fn = _intuit_file_patched($fn{old}, $fn{new}); + + my $dirname = $fn; + if ($dirname =~ s{/[^/]+$}{} and not -d $dirname) { + $dirtocreate{$dirname} = 1; + } + + if (-e $fn) { + if (not -f _) { + error(g_("diff '%s' patches something which is not a plain file"), + $diff); + } + # Note: We cannot use "stat _" due to Time::HiRes. + my $nlink = (stat $fn)[3]; + if ($nlink > 1) { + warning(g_("diff '%s' patches hard link %s which can have " . + 'unintended consequences'), $diff, $fn); + } + } + + if ($filepatched{$fn}) { + $filepatched{$fn}++; + + if ($opts{fatal_dupes}) { + error(g_("diff '%s' patches files multiple times; split the " . + 'diff in multiple files or merge the hunks into a ' . + 'single one'), $diff); + } elsif ($opts{verbose} and $filepatched{$fn} == 2) { + warning(g_("diff '%s' patches file %s more than once"), $diff, $fn) + } + } else { + $filepatched{$fn} = 1; + push @patchorder, $fn; + } + + # read hunks + my $hunk = 0; + while (defined($line = _getline($self))) { + # read hunk header (@@) + next if $line =~ /^\\ /; + last unless $line =~ /^@@ -\d+(,(\d+))? \+\d+(,(\d+))? @\@(?: .*)?$/; + my ($olines, $nlines) = ($1 ? $2 : 1, $3 ? $4 : 1); + # read hunk + while ($olines || $nlines) { + unless (defined($line = _getline($self))) { + if (($olines == $nlines) and ($olines < 3)) { + warning(g_("unexpected end of diff '%s'"), $diff) + if $opts{verbose}; + last; + } else { + error(g_("unexpected end of diff '%s'"), $diff); + } + } + next if $line =~ /^\\ /; + # Check stats + if ($line =~ /^ / or length $line == 0) { + --$olines; + --$nlines; + } elsif ($line =~ /^-/) { + --$olines; + } elsif ($line =~ /^\+/) { + --$nlines; + } else { + error(g_("expected [ +-] at start of line %d of diff '%s'"), + $., $diff); + } + } + $hunk++; + } + unless ($hunk) { + error(g_("expected ^\@\@ at line %d of diff '%s'"), $., $diff); + } + } + close($self); + unless ($diff_count) { + warning(g_("diff '%s' doesn't contain any patch"), $diff) + if $opts{verbose}; + } + *$self->{analysis}{$destdir}{dirtocreate} = \%dirtocreate; + *$self->{analysis}{$destdir}{filepatched} = \%filepatched; + *$self->{analysis}{$destdir}{patchorder} = \@patchorder; + *$self->{analysis}{$destdir}{patchheader} = $patch_header; + return *$self->{analysis}{$destdir}; +} + +sub prepare_apply { + my ($self, $analysis, %opts) = @_; + if ($opts{create_dirs}) { + foreach my $dir (keys %{$analysis->{dirtocreate}}) { + eval { make_path($dir, { mode => 0777 }) }; + syserr(g_('cannot create directory %s'), $dir) if $@; + } + } +} + +sub apply { + my ($self, $destdir, %opts) = @_; + # Set default values to options + $opts{force_timestamp} //= 1; + $opts{remove_backup} //= 1; + $opts{create_dirs} //= 1; + $opts{options} ||= [ + '-t', + '-F', '0', + '-N', + '-p1', + '-u', + '-V', 'never', + '-b', + '-z', '.dpkg-orig', + ]; + $opts{add_options} //= []; + push @{$opts{options}}, @{$opts{add_options}}; + # Check the diff and create missing directories + my $analysis = $self->analyze($destdir, %opts); + $self->prepare_apply($analysis, %opts); + # Apply the patch + $self->ensure_open('r'); + my ($stdout, $stderr) = ('', ''); + spawn( + exec => [ $Dpkg::PROGPATCH, @{$opts{options}} ], + chdir => $destdir, + env => { LC_ALL => 'C', PATCH_GET => '0' }, + delete_env => [ 'POSIXLY_CORRECT' ], # ensure expected patch behaviour + wait_child => 1, + nocheck => 1, + from_handle => $self->get_filehandle(), + to_string => \$stdout, + error_to_string => \$stderr, + ); + if ($?) { + print { *STDOUT } $stdout; + print { *STDERR } $stderr; + subprocerr("LC_ALL=C $Dpkg::PROGPATCH " . join(' ', @{$opts{options}}) . + ' < ' . $self->get_filename()); + } + $self->close(); + # Reset the timestamp of all the patched files + # and remove .dpkg-orig files + my @files = keys %{$analysis->{filepatched}}; + my $now = $opts{timestamp}; + $now //= fs_time($files[0]) if $opts{force_timestamp} && scalar @files; + foreach my $fn (@files) { + if ($opts{force_timestamp}) { + utime($now, $now, $fn) or $! == ENOENT + or syserr(g_('cannot change timestamp for %s'), $fn); + } + if ($opts{remove_backup}) { + $fn .= '.dpkg-orig'; + unlink($fn) or syserr(g_('remove patch backup file %s'), $fn); + } + } + return $analysis; +} + +# Verify if check will work... +sub check_apply { + my ($self, $destdir, %opts) = @_; + # Set default values to options + $opts{create_dirs} //= 1; + $opts{options} ||= [ + '--dry-run', + '-s', + '-t', + '-F', '0', + '-N', + '-p1', + '-u', + '-V', 'never', + '-b', + '-z', '.dpkg-orig', + ]; + $opts{add_options} //= []; + push @{$opts{options}}, @{$opts{add_options}}; + # Check the diff and create missing directories + my $analysis = $self->analyze($destdir, %opts); + $self->prepare_apply($analysis, %opts); + # Apply the patch + $self->ensure_open('r'); + my $patch_pid = spawn( + exec => [ $Dpkg::PROGPATCH, @{$opts{options}} ], + chdir => $destdir, + env => { LC_ALL => 'C', PATCH_GET => '0' }, + delete_env => [ 'POSIXLY_CORRECT' ], # ensure expected patch behaviour + from_handle => $self->get_filehandle(), + to_file => '/dev/null', + error_to_file => '/dev/null', + ); + wait_child($patch_pid, nocheck => 1); + my $exit = WEXITSTATUS($?); + subprocerr("$Dpkg::PROGPATCH --dry-run") unless WIFEXITED($?); + $self->close(); + return ($exit == 0); +} + +# Helper functions +sub get_type { + my $file = shift; + if (not lstat($file)) { + return g_('nonexistent') if $! == ENOENT; + syserr(g_('cannot stat %s'), $file); + } else { + -f _ && return g_('plain file'); + -d _ && return g_('directory'); + -l _ && return sprintf(g_('symlink to %s'), readlink($file)); + -b _ && return g_('block device'); + -c _ && return g_('character device'); + -p _ && return g_('named pipe'); + -S _ && return g_('named socket'); + } +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Source/Quilt.pm b/scripts/Dpkg/Source/Quilt.pm new file mode 100644 index 0000000..30373e6 --- /dev/null +++ b/scripts/Dpkg/Source/Quilt.pm @@ -0,0 +1,407 @@ +# Copyright © 2008-2012 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Source::Quilt - represent a quilt patch queue + +=head1 DESCRIPTION + +This module provides a class to handle quilt patch queues. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Source::Quilt 0.02; + +use strict; +use warnings; + +use List::Util qw(any none); +use File::Spec; +use File::Copy; +use File::Find; +use File::Path qw(make_path); +use File::Basename; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::File; +use Dpkg::Source::Patch; +use Dpkg::Source::Functions qw(erasedir chmod_if_needed fs_time); +use Dpkg::Vendor qw(get_current_vendor); + +sub new { + my ($this, $dir, %opts) = @_; + my $class = ref($this) || $this; + + my $self = { + dir => $dir, + }; + bless $self, $class; + + $self->load_series(); + $self->load_db(); + + return $self; +} + +sub setup_db { + my $self = shift; + my $db_dir = $self->get_db_dir(); + if (not -d $db_dir) { + mkdir $db_dir or syserr(g_('cannot mkdir %s'), $db_dir); + } + my $file = $self->get_db_file('.version'); + if (not -e $file) { + file_dump($file, "2\n"); + } + # The files below are used by quilt to know where patches are stored + # and what file contains the patch list (supported by quilt >= 0.48-5 + # in Debian). + $file = $self->get_db_file('.quilt_patches'); + if (not -e $file) { + file_dump($file, "debian/patches\n"); + } + $file = $self->get_db_file('.quilt_series'); + if (not -e $file) { + my $series = $self->get_series_file(); + $series = (File::Spec->splitpath($series))[2]; + file_dump($file, "$series\n"); + } +} + +sub load_db { + my $self = shift; + + my $pc_applied = $self->get_db_file('applied-patches'); + $self->{applied_patches} = [ $self->read_patch_list($pc_applied) ]; +} + +sub save_db { + my $self = shift; + + $self->setup_db(); + my $pc_applied = $self->get_db_file('applied-patches'); + $self->write_patch_list($pc_applied, $self->{applied_patches}); +} + +sub load_series { + my ($self, %opts) = @_; + + my $series = $self->get_series_file(); + $self->{series} = [ $self->read_patch_list($series, %opts) ]; +} + +sub series { + my $self = shift; + return @{$self->{series}}; +} + +sub applied { + my $self = shift; + return @{$self->{applied_patches}}; +} + +sub top { + my $self = shift; + my $count = scalar @{$self->{applied_patches}}; + return $self->{applied_patches}[$count - 1] if $count; + return; +} + +sub register { + my ($self, $patch_name) = @_; + + return if any { $_ eq $patch_name } @{$self->{series}}; + + # Add patch to series files. + $self->setup_db(); + $self->_file_add_line($self->get_series_file(), $patch_name); + $self->_file_add_line($self->get_db_file('applied-patches'), $patch_name); + $self->load_db(); + $self->load_series(); + + # Ensure quilt meta-data is created and in sync with some trickery: + # Reverse-apply the patch, drop .pc/$patch, and re-apply it with the + # correct options to recreate the backup files. + $self->pop(reverse_apply => 1); + $self->push(); +} + +sub unregister { + my ($self, $patch_name) = @_; + + return if none { $_ eq $patch_name } @{$self->{series}}; + + my $series = $self->get_series_file(); + + $self->_file_drop_line($series, $patch_name); + $self->_file_drop_line($self->get_db_file('applied-patches'), $patch_name); + erasedir($self->get_db_file($patch_name)); + $self->load_db(); + $self->load_series(); + + # Clean up empty series. + unlink $series if -z $series; +} + +sub next { + my $self = shift; + my $count_applied = scalar @{$self->{applied_patches}}; + my $count_series = scalar @{$self->{series}}; + return $self->{series}[$count_applied] if ($count_series > $count_applied); + return; +} + +sub push { + my ($self, %opts) = @_; + $opts{verbose} //= 0; + $opts{timestamp} //= fs_time($self->{dir}); + + my $patch = $self->next(); + return unless defined $patch; + + my $path = $self->get_patch_file($patch); + my $obj = Dpkg::Source::Patch->new(filename => $path); + + info(g_('applying %s'), $patch) if $opts{verbose}; + eval { + $obj->apply($self->{dir}, timestamp => $opts{timestamp}, + verbose => $opts{verbose}, + force_timestamp => 1, create_dirs => 1, remove_backup => 0, + options => [ '-t', '-F', '0', '-N', '-p1', '-u', + '-V', 'never', '-E', '-b', + '-B', ".pc/$patch/", '--reject-file=-' ]); + }; + if ($@) { + info(g_('the patch has fuzz which is not allowed, or is malformed')); + info(g_("if patch '%s' is correctly applied by quilt, use '%s' to update it"), + $patch, 'quilt refresh'); + info(g_('if the file is present in the unpacked source, make sure it ' . + 'is also present in the orig tarball')); + $self->restore_quilt_backup_files($patch, %opts); + erasedir($self->get_db_file($patch)); + die $@; + } + CORE::push @{$self->{applied_patches}}, $patch; + $self->save_db(); +} + +sub pop { + my ($self, %opts) = @_; + $opts{verbose} //= 0; + $opts{timestamp} //= fs_time($self->{dir}); + $opts{reverse_apply} //= 0; + + my $patch = $self->top(); + return unless defined $patch; + + info(g_('unapplying %s'), $patch) if $opts{verbose}; + my $backup_dir = $self->get_db_file($patch); + if (-d $backup_dir and not $opts{reverse_apply}) { + # Use the backup copies to restore + $self->restore_quilt_backup_files($patch); + } else { + # Otherwise reverse-apply the patch + my $path = $self->get_patch_file($patch); + my $obj = Dpkg::Source::Patch->new(filename => $path); + + $obj->apply($self->{dir}, timestamp => $opts{timestamp}, + verbose => 0, force_timestamp => 1, remove_backup => 0, + options => [ '-R', '-t', '-N', '-p1', + '-u', '-V', 'never', '-E', + '--no-backup-if-mismatch' ]); + } + + erasedir($backup_dir); + pop @{$self->{applied_patches}}; + $self->save_db(); +} + +sub get_db_version { + my $self = shift; + my $pc_ver = $self->get_db_file('.version'); + if (-f $pc_ver) { + my $version = file_slurp($pc_ver); + chomp $version; + return $version; + } + return; +} + +sub find_problems { + my $self = shift; + my $patch_dir = $self->get_patch_dir(); + if (-e $patch_dir and not -d _) { + return sprintf(g_('%s should be a directory or non-existing'), $patch_dir); + } + my $series = $self->get_series_file(); + if (-e $series and not -f _) { + return sprintf(g_('%s should be a file or non-existing'), $series); + } + return; +} + +sub get_series_file { + my $self = shift; + my $vendor = lc(get_current_vendor() || 'debian'); + # Series files are stored alongside patches + my $default_series = $self->get_patch_file('series'); + my $vendor_series = $self->get_patch_file("$vendor.series"); + return $vendor_series if -e $vendor_series; + return $default_series; +} + +sub get_db_file { + my ($self, $file) = @_; + + return File::Spec->catfile($self->get_db_dir(), $file); +} + +sub get_db_dir { + my $self = shift; + + return File::Spec->catfile($self->{dir}, '.pc'); +} + +sub get_patch_file { + my ($self, $file) = @_; + + return File::Spec->catfile($self->get_patch_dir(), $file); +} + +sub get_patch_dir { + my $self = shift; + + return File::Spec->catfile($self->{dir}, 'debian', 'patches'); +} + +## METHODS BELOW ARE INTERNAL ## + +sub _file_load { + my ($self, $file) = @_; + + open my $file_fh, '<', $file or syserr(g_('cannot read %s'), $file); + my @lines = <$file_fh>; + close $file_fh; + + return @lines; +} + +sub _file_add_line { + my ($self, $file, $line) = @_; + + my @lines; + @lines = $self->_file_load($file) if -f $file; + CORE::push @lines, $line; + chomp @lines; + + open my $file_fh, '>', $file or syserr(g_('cannot write %s'), $file); + print { $file_fh } "$_\n" foreach @lines; + close $file_fh; +} + +sub _file_drop_line { + my ($self, $file, $re) = @_; + + my @lines = $self->_file_load($file); + open my $file_fh, '>', $file or syserr(g_('cannot write %s'), $file); + print { $file_fh } $_ foreach grep { not /^\Q$re\E\s*$/ } @lines; + close $file_fh; +} + +sub read_patch_list { + my ($self, $file, %opts) = @_; + return () if not defined $file or not -f $file; + $opts{warn_options} //= 0; + my @patches; + open(my $series_fh, '<' , $file) or syserr(g_('cannot read %s'), $file); + while (defined(my $line = <$series_fh>)) { + chomp $line; + # Strip leading/trailing spaces + $line =~ s/^\s+//; + $line =~ s/\s+$//; + # Strip comment + $line =~ s/(?:^|\s+)#.*$//; + next unless $line; + if ($line =~ /^(\S+)\s+(.*)$/) { + $line = $1; + if ($2 ne '-p1') { + warning(g_('the series file (%s) contains unsupported ' . + "options ('%s', line %s); dpkg-source might " . + 'fail when applying patches'), + $file, $2, $.) if $opts{warn_options}; + } + } + if ($line =~ m{(^|/)\.\./}) { + error(g_('%s contains an insecure path: %s'), $file, $line); + } + CORE::push @patches, $line; + } + close($series_fh); + return @patches; +} + +sub write_patch_list { + my ($self, $series, $patches) = @_; + + open my $series_fh, '>', $series or syserr(g_('cannot write %s'), $series); + foreach my $patch (@{$patches}) { + print { $series_fh } "$patch\n"; + } + close $series_fh; +} + +sub restore_quilt_backup_files { + my ($self, $patch, %opts) = @_; + my $patch_dir = $self->get_db_file($patch); + return unless -d $patch_dir; + info(g_('restoring quilt backup files for %s'), $patch) if $opts{verbose}; + find({ + no_chdir => 1, + wanted => sub { + return if -d; + my $relpath_in_srcpkg = File::Spec->abs2rel($_, $patch_dir); + my $target = File::Spec->catfile($self->{dir}, $relpath_in_srcpkg); + if (-s) { + unlink($target); + make_path(dirname($target)); + unless (link($_, $target)) { + copy($_, $target) + or syserr(g_('failed to copy %s to %s'), $_, $target); + chmod_if_needed((stat _)[2], $target) + or syserr(g_("unable to change permission of '%s'"), $target); + } + } else { + # empty files are "backups" for new files that patch created + unlink($target); + } + } + }, $patch_dir); +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Substvars.pm b/scripts/Dpkg/Substvars.pm new file mode 100644 index 0000000..cf55194 --- /dev/null +++ b/scripts/Dpkg/Substvars.pm @@ -0,0 +1,503 @@ +# Copyright © 2006-2009, 2012-2020, 2022 Guillem Jover <guillem@debian.org> +# Copyright © 2007-2010 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Substvars - handle variable substitution in strings + +=head1 DESCRIPTION + +It provides a class which is able to substitute variables in strings. + +=cut + +package Dpkg::Substvars 2.01; + +use strict; +use warnings; + +use Dpkg (); +use Dpkg::Arch qw(get_host_arch); +use Dpkg::Vendor qw(get_current_vendor); +use Dpkg::Version; +use Dpkg::ErrorHandling; +use Dpkg::Gettext; + +use parent qw(Dpkg::Interface::Storable); + +my $maxsubsts = 50; + +use constant { + SUBSTVAR_ATTR_USED => 1, + SUBSTVAR_ATTR_AUTO => 2, + SUBSTVAR_ATTR_AGED => 4, + SUBSTVAR_ATTR_OPT => 8, + SUBSTVAR_ATTR_DEEP => 16, +}; + +=head1 METHODS + +=over 8 + +=item $s = Dpkg::Substvars->new($file) + +Create a new object that can do substitutions. By default it contains +generic substitutions like ${Newline}, ${Space}, ${Tab}, ${dpkg:Version} +and ${dpkg:Upstream-Version}. + +Additional substitutions will be read from the $file passed as parameter. + +It keeps track of which substitutions were actually used (only counting +substvars(), not get()), and warns about unused substvars when asked to. The +substitutions that are always present are not included in these warnings. + +=cut + +sub new { + my ($this, $arg) = @_; + my $class = ref($this) || $this; + my $self = { + vars => { + 'Newline' => "\n", + 'Space' => ' ', + 'Tab' => "\t", + 'dpkg:Version' => $Dpkg::PROGVERSION, + 'dpkg:Upstream-Version' => $Dpkg::PROGVERSION, + }, + attr => {}, + msg_prefix => '', + }; + $self->{vars}{'dpkg:Upstream-Version'} =~ s/-[^-]+$//; + bless $self, $class; + + my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; + $self->{attr}{$_} = $attr foreach keys %{$self->{vars}}; + if ($arg) { + $self->load($arg) if -e $arg; + } + return $self; +} + +=item $s->set($key, $value) + +Add/replace a substitution. + +=cut + +sub set { + my ($self, $key, $value, $attr) = @_; + + $attr //= 0; + $attr |= SUBSTVAR_ATTR_DEEP if length $value && $value =~ m{\$}; + + $self->{vars}{$key} = $value; + $self->{attr}{$key} = $attr; +} + +=item $s->set_as_used($key, $value) + +Add/replace a substitution and mark it as used (no warnings will be produced +even if unused). + +=cut + +sub set_as_used { + my ($self, $key, $value) = @_; + + $self->set($key, $value, SUBSTVAR_ATTR_USED); +} + +=item $s->set_as_auto($key, $value) + +Add/replace a substitution and mark it as used and automatic (no warnings +will be produced even if unused). + +=cut + +sub set_as_auto { + my ($self, $key, $value) = @_; + + $self->set($key, $value, SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO); +} + +=item $s->get($key) + +Get the value of a given substitution. + +=cut + +sub get { + my ($self, $key) = @_; + return $self->{vars}{$key}; +} + +=item $s->delete($key) + +Remove a given substitution. + +=cut + +sub delete { + my ($self, $key) = @_; + delete $self->{attr}{$key}; + return delete $self->{vars}{$key}; +} + +=item $s->mark_as_used($key) + +Prevents warnings about a unused substitution, for example if it is provided by +default. + +=cut + +sub mark_as_used { + my ($self, $key) = @_; + $self->{attr}{$key} |= SUBSTVAR_ATTR_USED; +} + +=item $s->parse($fh, $desc) + +Add new substitutions read from the filehandle. $desc is used to identify +the filehandle in error messages. + +Returns the number of substitutions that have been parsed with success. + +=cut + +sub parse { + my ($self, $fh, $varlistfile) = @_; + my $count = 0; + local $_; + + binmode($fh); + while (<$fh>) { + my $attr; + + next if m/^\s*\#/ || !m/\S/; + s/\s*\n$//; + if (! m/^(\w[-:0-9A-Za-z]*)(\?)?\=(.*)$/) { + error(g_('bad line in substvars file %s at line %d'), + $varlistfile, $.); + } + ## no critic (RegularExpressions::ProhibitCaptureWithoutTest) + if (defined $2) { + $attr = (SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_OPT) if $2 eq '?'; + } + $self->set($1, $3, $attr); + $count++; + } + + return $count +} + +=item $s->load($file) + +Add new substitutions read from $file. + +=item $s->set_version_substvars($sourceversion, $binaryversion) + +Defines ${binary:Version}, ${source:Version} and +${source:Upstream-Version} based on the given version strings. + +These will never be warned about when unused. + +=cut + +sub set_version_substvars { + my ($self, $sourceversion, $binaryversion) = @_; + + # Handle old function signature taking only one argument. + $binaryversion //= $sourceversion; + + # For backwards compatibility on binNMUs that do not use the Binary-Only + # field on the changelog, always fix up the source version. + $sourceversion =~ s/\+b[0-9]+$//; + + my $vs = Dpkg::Version->new($sourceversion, check => 1); + if (not defined $vs) { + error(g_('invalid source version %s'), $sourceversion); + } + my $upstreamversion = $vs->as_string(omit_revision => 1); + + my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; + + $self->set('binary:Version', $binaryversion, $attr); + $self->set('source:Version', $sourceversion, $attr); + $self->set('source:Upstream-Version', $upstreamversion, $attr); + + # XXX: Source-Version is now obsolete, remove in 1.19.x. + $self->set('Source-Version', $binaryversion, $attr | SUBSTVAR_ATTR_AGED); +} + +=item $s->set_arch_substvars() + +Defines architecture variables: ${Arch}. + +This will never be warned about when unused. + +=cut + +sub set_arch_substvars { + my $self = shift; + + my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; + + $self->set('Arch', get_host_arch(), $attr); +} + +=item $s->set_vendor_substvars() + +Defines vendor variables: ${vendor:Name} and ${vendor:Id}. + +These will never be warned about when unused. + +=cut + +sub set_vendor_substvars { + my ($self, $desc) = @_; + + my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; + + my $vendor = get_current_vendor(); + $self->set('vendor:Name', $vendor, $attr); + $self->set('vendor:Id', lc $vendor, $attr); +} + +=item $s->set_desc_substvars() + +Defines source description variables: ${source:Synopsis} and +${source:Extended-Description}. + +These will never be warned about when unused. + +=cut + +sub set_desc_substvars { + my ($self, $desc) = @_; + + my ($synopsis, $extended) = split /\n/, $desc, 2; + + my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; + + $self->set('source:Synopsis', $synopsis, $attr); + $self->set('source:Extended-Description', $extended, $attr); +} + +=item $s->set_field_substvars($ctrl, $prefix) + +Defines field variables from a L<Dpkg::Control> object, with each variable +having the form "${$prefix:$field}". + +They will never be warned about when unused. + +=cut + +sub set_field_substvars { + my ($self, $ctrl, $prefix) = @_; + + foreach my $field (keys %{$ctrl}) { + $self->set_as_auto("$prefix:$field", $ctrl->{$field}); + } +} + +=item $newstring = $s->substvars($string) + +Substitutes variables in $string and return the result in $newstring. + +=cut + +sub substvars { + my ($self, $v, %opts) = @_; + my %seen; + my $lhs; + my $vn; + my $rhs = ''; + $opts{msg_prefix} //= $self->{msg_prefix}; + $opts{no_warn} //= 0; + + while ($v =~ m/^(.*?)\$\{([-:0-9a-z]+)\}(.*)$/si) { + $lhs = $1; + $vn = $2; + $rhs = $3; + + if (defined($self->{vars}{$vn})) { + $v = $lhs . $self->{vars}{$vn} . $rhs; + $self->mark_as_used($vn); + + if ($self->{attr}{$vn} & SUBSTVAR_ATTR_DEEP) { + $seen{$vn}++; + } + if (exists $seen{$vn} && $seen{$vn} >= $maxsubsts) { + error($opts{msg_prefix} . + g_("too many \${%s} substitutions (recursive?) in '%s'"), + $vn, $v); + } + + if ($self->{attr}{$vn} & SUBSTVAR_ATTR_AGED) { + error($opts{msg_prefix} . + g_('obsolete substitution variable ${%s}'), $vn); + } + } else { + warning($opts{msg_prefix} . + g_('substitution variable ${%s} used, but is not defined'), + $vn) unless $opts{no_warn}; + $v = $lhs . $rhs; + } + } + return $v; +} + +=item $s->warn_about_unused() + +Issues warning about any variables that were set, but not used. + +=cut + +sub warn_about_unused { + my ($self, %opts) = @_; + $opts{msg_prefix} //= $self->{msg_prefix}; + + foreach my $vn (sort keys %{$self->{vars}}) { + next if $self->{attr}{$vn} & SUBSTVAR_ATTR_USED; + # Empty substitutions variables are ignored on the basis + # that they are not required in the current situation + # (example: debhelper's misc:Depends in many cases) + next if $self->{vars}{$vn} eq ''; + warning($opts{msg_prefix} . + g_('substitution variable ${%s} unused, but is defined'), + $vn); + } +} + +=item $s->set_msg_prefix($prefix) + +Define a prefix displayed before all warnings/error messages output +by the module. + +=cut + +sub set_msg_prefix { + my ($self, $prefix) = @_; + $self->{msg_prefix} = $prefix; +} + +=item $s->filter(remove => $rmfunc) + +=item $s->filter(keep => $keepfun) + +Filter the substitution variables, either removing or keeping all those +that return true when $rmfunc->($key) or $keepfunc->($key) is called. + +=cut + +sub filter { + my ($self, %opts) = @_; + + my $remove = $opts{remove} // sub { 0 }; + my $keep = $opts{keep} // sub { 1 }; + + foreach my $vn (keys %{$self->{vars}}) { + $self->delete($vn) if $remove->($vn) or not $keep->($vn); + } +} + +=item "$s" + +Return a string representation of all substitutions variables except the +automatic ones. + +=item $str = $s->output([$fh]) + +Return all substitutions variables except the automatic ones. If $fh +is passed print them into the filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + my $str = ''; + # Store all non-automatic substitutions only + foreach my $vn (sort keys %{$self->{vars}}) { + next if $self->{attr}{$vn} & SUBSTVAR_ATTR_AUTO; + my $op = $self->{attr}{$vn} & SUBSTVAR_ATTR_OPT ? '?=' : '='; + my $line = "$vn$op" . $self->{vars}{$vn} . "\n"; + print { $fh } $line if defined $fh; + $str .= $line; + } + return $str; +} + +=item $s->save($file) + +Store all substitutions variables except the automatic ones in the +indicated file. + +=back + +=head1 CHANGES + +=head2 Version 2.01 (dpkg 1.21.8) + +New feature: Add support for optional substitution variables. + +=head2 Version 2.00 (dpkg 1.20.0) + +Remove method: $s->no_warn(). + +New method: $s->set_vendor_substvars(). + +=head2 Version 1.06 (dpkg 1.19.0) + +New method: $s->set_desc_substvars(). + +=head2 Version 1.05 (dpkg 1.18.11) + +Obsolete substvar: Emit an error on Source-Version substvar usage. + +New return: $s->parse() now returns the number of parsed substvars. + +New method: $s->set_field_substvars(). + +=head2 Version 1.04 (dpkg 1.18.0) + +New method: $s->filter(). + +=head2 Version 1.03 (dpkg 1.17.11) + +New method: $s->set_as_auto(). + +=head2 Version 1.02 (dpkg 1.16.5) + +New argument: Accept a $binaryversion in $s->set_version_substvars(), +passing a single argument is still supported. + +New method: $s->mark_as_used(). + +Deprecated method: $s->no_warn(), use $s->mark_as_used() instead. + +=head2 Version 1.01 (dpkg 1.16.4) + +New method: $s->set_as_used(). + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Vendor.pm b/scripts/Dpkg/Vendor.pm new file mode 100644 index 0000000..feec75c --- /dev/null +++ b/scripts/Dpkg/Vendor.pm @@ -0,0 +1,291 @@ +# Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2017, 2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Vendor - get access to some vendor specific information + +=head1 DESCRIPTION + +The files in $Dpkg::CONFDIR/origins/ can provide information about various +vendors who are providing Debian packages. Currently those files look like +this: + + Vendor: Debian + Vendor-URL: https://www.debian.org/ + Bugs: debbugs://bugs.debian.org + +If the vendor derives from another vendor, the file should document +the relationship by listing the base distribution in the Parent field: + + Parent: Debian + +The file should be named according to the vendor name. The usual convention +is to name the vendor file using the vendor name in all lowercase, but some +variation is permitted. Namely, spaces are mapped to dashes ('-'), and the +file can have the same casing as the Vendor field, or it can be capitalized. + +=cut + +package Dpkg::Vendor 1.02; + +use strict; +use warnings; +use feature qw(state); + +our @EXPORT_OK = qw( + get_current_vendor + get_vendor_info + get_vendor_file + get_vendor_dir + get_vendor_object + run_vendor_hook +); + +use Exporter qw(import); +use List::Util qw(uniq); + +use Dpkg (); +use Dpkg::ErrorHandling; +use Dpkg::Gettext; +use Dpkg::BuildEnv; +use Dpkg::Control::HashCore; + +my $origins = "$Dpkg::CONFDIR/origins"; +$origins = $ENV{DPKG_ORIGINS_DIR} if $ENV{DPKG_ORIGINS_DIR}; + +=head1 FUNCTIONS + +=over 4 + +=item $dir = get_vendor_dir() + +Returns the current dpkg origins directory name, where the vendor files +are stored. + +=cut + +sub get_vendor_dir { + return $origins; +} + +=item $fields = get_vendor_info($name) + +Returns a L<Dpkg::Control> object with the information parsed from the +corresponding vendor file in $Dpkg::CONFDIR/origins/. If $name is omitted, +it will use $Dpkg::CONFDIR/origins/default which is supposed to be a symlink +to the vendor of the currently installed operating system. Returns undef +if there's no file for the given vendor. + +=cut + +my $vendor_sep_regex = qr{[^A-Za-z0-9]+}; + +sub get_vendor_info(;$) { + my $vendor = shift || 'default'; + my $vendor_key = lc $vendor =~ s{$vendor_sep_regex}{}gr; + state %VENDOR_CACHE; + return $VENDOR_CACHE{$vendor_key} if exists $VENDOR_CACHE{$vendor_key}; + + my $file = get_vendor_file($vendor); + return unless $file; + my $fields = Dpkg::Control::HashCore->new(); + $fields->load($file, compression => 0) or error(g_('%s is empty'), $file); + $VENDOR_CACHE{$vendor_key} = $fields; + return $fields; +} + +=item $name = get_vendor_file($name) + +Check if there's a file for the given vendor and returns its +name. + +The vendor filename will be derived from the vendor name, by replacing any +number of non-alphanumeric characters (that is B<[^A-Za-z0-9]>) into "B<->", +then the resulting name will be tried in sequence by lower-casing it, +keeping it as is, lower-casing then capitalizing it, and capitalizing it. + +In addition, for historical and backwards compatibility, the name will +be tried keeping it as is without non-alphanumeric characters remapping, +then the resulting name will be tried in sequence by lower-casing it, +keeping it as is, lower-casing then capitalizing it, and capitalizing it. +And finally the name will be tried by replacing only spaces to "B<->", +then the resulting name will be tried in sequence by lower-casing it, +keeping it as is, lower-casing then capitalizing it, and capitalizing it. + +But these backwards compatible name lookups will be removed during +the dpkg 1.22.x release cycle. + +=cut + +sub get_vendor_file(;$) { + my $vendor = shift || 'default'; + + my @names; + my $vendor_sep = $vendor =~ s{$vendor_sep_regex}{-}gr; + push @names, lc $vendor_sep, $vendor_sep, ucfirst lc $vendor_sep, ucfirst $vendor_sep; + + # XXX: Backwards compatibility, remove on 1.22.x. + my %name_seen = map { $_ => 1 } @names; + my @obsolete_names = uniq grep { + my $seen = exists $name_seen{$_}; + $name_seen{$_} = 1; + not $seen; + } ( + (lc $vendor, $vendor, ucfirst lc $vendor, ucfirst $vendor), + ($vendor =~ s{\s+}{-}g) ? + (lc $vendor, $vendor, ucfirst lc $vendor, ucfirst $vendor) : () + ); + my %obsolete_name = map { $_ => 1 } @obsolete_names; + push @names, @obsolete_names; + + foreach my $name (uniq @names) { + next unless -e "$origins/$name"; + if (exists $obsolete_name{$name}) { + warning(g_('%s origin filename is deprecated; ' . + 'it should have only alphanumeric or dash characters'), + $name); + } + return "$origins/$name"; + } + return; +} + +=item $name = get_current_vendor() + +Returns the name of the current vendor. If DEB_VENDOR is set, it uses +that first, otherwise it falls back to parsing $Dpkg::CONFDIR/origins/default. +If that file doesn't exist, it returns undef. + +=cut + +sub get_current_vendor() { + my $f; + if (Dpkg::BuildEnv::has('DEB_VENDOR')) { + $f = get_vendor_info(Dpkg::BuildEnv::get('DEB_VENDOR')); + return $f->{'Vendor'} if defined $f; + } + $f = get_vendor_info(); + return $f->{'Vendor'} if defined $f; + return; +} + +=item $object = get_vendor_object($name) + +Return the Dpkg::Vendor::* object of the corresponding vendor. +If $name is omitted, return the object of the current vendor. +If no vendor can be identified, then return the L<Dpkg::Vendor::Default> +object. + +The module name will be derived from the vendor name, by splitting parts +around groups of non alphanumeric character (that is B<[^A-Za-z0-9]>) +separators, by either capitalizing or lower-casing and capitalizing each part +and then joining them without the separators. So the expected casing is based +on the one from the B<Vendor> field in the F<origins> file. + +In addition, for historical and backwards compatibility, the module name +will also be looked up without non-alphanumeric character stripping, by +capitalizing, lower-casing then capitalizing, as-is or lower-casing. +But these name lookups will be removed during the 1.22.x release cycle. + +=cut + +sub get_vendor_object { + my $vendor = shift || get_current_vendor() || 'Default'; + my $vendor_key = lc $vendor =~ s{$vendor_sep_regex}{}gr; + state %OBJECT_CACHE; + return $OBJECT_CACHE{$vendor_key} if exists $OBJECT_CACHE{$vendor_key}; + + my ($obj, @names); + + my @vendor_parts = split m{$vendor_sep_regex}, $vendor; + push @names, join q{}, map { ucfirst } @vendor_parts; + push @names, join q{}, map { ucfirst lc } @vendor_parts; + + # XXX: Backwards compatibility, remove on 1.22.x. + my %name_seen = map { $_ => 1 } @names; + my @obsolete_names = uniq grep { + my $seen = exists $name_seen{$_}; + $name_seen{$_} = 1; + not $seen; + } (ucfirst $vendor, ucfirst lc $vendor, $vendor, lc $vendor); + my %obsolete_name = map { $_ => 1 } @obsolete_names; + push @names, @obsolete_names; + + foreach my $name (uniq @names) { + eval qq{ + require Dpkg::Vendor::$name; + \$obj = Dpkg::Vendor::$name->new(); + }; + unless ($@) { + $OBJECT_CACHE{$vendor_key} = $obj; + if (exists $obsolete_name{$name}) { + warning(g_('%s module name is deprecated; ' . + 'it should be capitalized with only alphanumeric characters'), + "Dpkg::Vendor::$name"); + } + return $obj; + } + } + + my $info = get_vendor_info($vendor); + if (defined $info and defined $info->{'Parent'}) { + return get_vendor_object($info->{'Parent'}); + } else { + return get_vendor_object('Default'); + } +} + +=item run_vendor_hook($hookid, @params) + +Run a hook implemented by the current vendor object. + +=cut + +sub run_vendor_hook { + my @args = @_; + my $vendor_obj = get_vendor_object(); + + $vendor_obj->run_hook(@args); +} + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.21.10) + +Deprecated behavior: get_vendor_file() loading vendor files with no special +characters remapping. get_vendor_object() loading vendor module names with +no special character stripping. + +=head2 Version 1.01 (dpkg 1.17.0) + +New function: get_vendor_dir(). + +=head2 Version 1.00 (dpkg 1.16.1) + +Mark the module as public. + +=head1 SEE ALSO + +L<deb-origin(5)>. + +=cut + +1; diff --git a/scripts/Dpkg/Vendor/Debian.pm b/scripts/Dpkg/Vendor/Debian.pm new file mode 100644 index 0000000..2d07794 --- /dev/null +++ b/scripts/Dpkg/Vendor/Debian.pm @@ -0,0 +1,633 @@ +# Copyright © 2009-2011 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2009, 2011-2017 Guillem Jover <guillem@debian.org> +# +# Hardening build flags handling derived from work of: +# Copyright © 2009-2011 Kees Cook <kees@debian.org> +# Copyright © 2007-2008 Canonical, Ltd. +# +# 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Vendor::Debian - Debian vendor class + +=head1 DESCRIPTION + +This vendor class customizes the behavior of dpkg scripts for Debian +specific behavior and policies. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Vendor::Debian 0.01; + +use strict; +use warnings; + +use List::Util qw(any none); + +use Dpkg; +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control::Types; + +use parent qw(Dpkg::Vendor::Default); + +sub run_hook { + my ($self, $hook, @params) = @_; + + if ($hook eq 'package-keyrings') { + return ('/usr/share/keyrings/debian-keyring.gpg', + '/usr/share/keyrings/debian-nonupload.gpg', + '/usr/share/keyrings/debian-maintainers.gpg'); + } elsif ($hook eq 'archive-keyrings') { + return ('/usr/share/keyrings/debian-archive-keyring.gpg'); + } elsif ($hook eq 'archive-keyrings-historic') { + return ('/usr/share/keyrings/debian-archive-removed-keys.gpg'); + } elsif ($hook eq 'builtin-build-depends') { + return qw(build-essential:native); + } elsif ($hook eq 'builtin-build-conflicts') { + return (); + } elsif ($hook eq 'register-custom-fields') { + } elsif ($hook eq 'extend-patch-header') { + my ($textref, $ch_info) = @params; + if ($ch_info->{'Closes'}) { + foreach my $bug (split(/\s+/, $ch_info->{'Closes'})) { + $$textref .= "Bug-Debian: https://bugs.debian.org/$bug\n"; + } + } + + # XXX: Layer violation... + require Dpkg::Vendor::Ubuntu; + my $b = Dpkg::Vendor::Ubuntu::find_launchpad_closes($ch_info->{'Changes'}); + foreach my $bug (@$b) { + $$textref .= "Bug-Ubuntu: https://bugs.launchpad.net/bugs/$bug\n"; + } + } elsif ($hook eq 'update-buildflags') { + $self->set_build_features(@params); + $self->_add_build_flags(@params); + } elsif ($hook eq 'builtin-system-build-paths') { + return qw(/build/); + } elsif ($hook eq 'build-tainted-by') { + return $self->_build_tainted_by(); + } elsif ($hook eq 'sanitize-environment') { + # Reset umask to a sane default. + umask 0022; + # Reset locale to a sane default. + $ENV{LC_COLLATE} = 'C.UTF-8'; + } elsif ($hook eq 'backport-version-regex') { + return qr/~(bpo|deb)/; + } else { + return $self->SUPER::run_hook($hook, @params); + } +} + +sub init_build_features { + my ($self, $use_feature, $builtin_feature) = @_; +} + +sub set_build_features { + my ($self, $flags) = @_; + + # Default feature states. + my %use_feature = ( + future => { + # XXX: Should start a deprecation cycle at some point. + lfs => 0, + }, + abi => { + # XXX: This is set to undef so that we can handle the alias from + # the future feature area. + lfs => undef, + time64 => 0, + }, + qa => { + bug => 0, + 'bug-implicit-func' => undef, + canary => 0, + }, + reproducible => { + timeless => 1, + fixfilepath => 1, + fixdebugpath => 1, + }, + optimize => { + lto => 0, + }, + sanitize => { + address => 0, + thread => 0, + leak => 0, + undefined => 0, + }, + hardening => { + # XXX: This is set to undef so that we can cope with the brokenness + # of gcc managing this feature builtin. + pie => undef, + stackprotector => 1, + stackprotectorstrong => 1, + stackclash => 1, + fortify => 1, + format => 1, + relro => 1, + bindnow => 0, + branch => 1, + }, + ); + + my %builtin_feature = ( + abi => { + lfs => 0, + time64 => 0, + }, + hardening => { + pie => 1, + }, + ); + + require Dpkg::Arch; + + my $arch = Dpkg::Arch::get_host_arch(); + my ($abi, $libc, $os, $cpu) = Dpkg::Arch::debarch_to_debtuple($arch); + my ($abi_bits, $abi_endian) = Dpkg::Arch::debarch_to_abiattrs($arch); + + unless (defined $abi and defined $libc and defined $os and defined $cpu) { + warning(g_("unknown host architecture '%s'"), $arch); + ($abi, $os, $cpu) = ('', '', ''); + } + unless (defined $abi_bits and defined $abi_endian) { + warning(g_("unknown abi attributes for architecture '%s'"), $arch); + ($abi_bits, $abi_endian) = (0, 'unknown'); + } + + # Mask builtin features that are not enabled by default in the compiler. + my %builtin_pie_arch = map { $_ => 1 } qw( + amd64 + arm64 + armel + armhf + hurd-amd64 + hurd-i386 + i386 + kfreebsd-amd64 + kfreebsd-i386 + loong64 + mips + mips64 + mips64el + mips64r6 + mips64r6el + mipsel + mipsn32 + mipsn32el + mipsn32r6 + mipsn32r6el + mipsr6 + mipsr6el + powerpc + ppc64 + ppc64el + riscv64 + s390x + sparc + sparc64 + ); + if (not exists $builtin_pie_arch{$arch}) { + $builtin_feature{hardening}{pie} = 0; + } + + if ($abi_bits != 32) { + $builtin_feature{abi}{lfs} = 1; + } + + # On glibc, new ports default to time64, old ports currently default + # to time32, so we track the latter as that is a list that is not + # going to grow further, and might shrink. + # On musl libc based systems all ports use time64. + my %time32_arch = map { $_ => 1 } qw( + arm + armeb + armel + armhf + hppa + i386 + hurd-i386 + kfreebsd-i386 + m68k + mips + mipsel + mipsn32 + mipsn32el + mipsn32r6 + mipsn32r6el + mipsr6 + mipsr6el + nios2 + powerpc + powerpcel + powerpcspe + s390 + sh3 + sh3eb + sh4 + sh4eb + sparc + ); + if ($abi_bits != 32 or + not exists $time32_arch{$arch} or + $libc eq 'musl') { + $builtin_feature{abi}{time64} = 1; + } + + $self->init_build_features(\%use_feature, \%builtin_feature); + + ## Setup + + require Dpkg::BuildOptions; + + # Adjust features based on user or maintainer's desires. + my $opts_build = Dpkg::BuildOptions->new(envvar => 'DEB_BUILD_OPTIONS'); + my $opts_maint = Dpkg::BuildOptions->new(envvar => 'DEB_BUILD_MAINT_OPTIONS'); + + foreach my $area (sort keys %use_feature) { + $opts_build->parse_features($area, $use_feature{$area}); + $opts_maint->parse_features($area, $use_feature{$area}); + } + + ## Area: abi + + if ($use_feature{abi}{time64} && ! $builtin_feature{abi}{time64}) { + # On glibc 64-bit time_t support requires LFS. + $use_feature{abi}{lfs} = 1 if $libc eq 'gnu'; + } + + # XXX: Handle lfs alias from future abi feature area. + $use_feature{abi}{lfs} //= $use_feature{future}{lfs}; + # XXX: Once the feature is set in the abi area, we always override the + # one in the future area. + $use_feature{future}{lfs} = $use_feature{abi}{lfs}; + + ## Area: qa + + $use_feature{qa}{'bug-implicit-func'} //= $use_feature{qa}{bug}; + + ## Area: reproducible + + # Mask features that might have an unsafe usage. + if ($use_feature{reproducible}{fixfilepath} or + $use_feature{reproducible}{fixdebugpath}) { + require Cwd; + + my $build_path =$ENV{DEB_BUILD_PATH} || Cwd::getcwd(); + + $flags->set_option_value('build-path', $build_path); + + # If we have any unsafe character in the path, disable the flag, + # so that we do not need to worry about escaping the characters + # on output. + if ($build_path =~ m/[^-+:.0-9a-zA-Z~\/_]/) { + $use_feature{reproducible}{fixfilepath} = 0; + $use_feature{reproducible}{fixdebugpath} = 0; + } + } + + ## Area: optimize + + if ($opts_build->has('noopt')) { + $flags->set_option_value('optimize-level', 0); + } else { + $flags->set_option_value('optimize-level', 2); + } + + ## Area: sanitize + + # Handle logical feature interactions. + if ($use_feature{sanitize}{address} and $use_feature{sanitize}{thread}) { + # Disable the thread sanitizer when the address one is active, they + # are mutually incompatible. + $use_feature{sanitize}{thread} = 0; + } + if ($use_feature{sanitize}{address} or $use_feature{sanitize}{thread}) { + # Disable leak sanitizer, it is implied by the address or thread ones. + $use_feature{sanitize}{leak} = 0; + } + + ## Area: hardening + + # Mask features that are not available on certain architectures. + if (none { $os eq $_ } qw(linux kfreebsd hurd) or + any { $cpu eq $_ } qw(alpha hppa ia64)) { + # Disabled on non-(linux/kfreebsd/hurd). + # Disabled on alpha, hppa, ia64. + $use_feature{hardening}{pie} = 0; + } + if (any { $cpu eq $_ } qw(ia64 alpha hppa nios2) or $arch eq 'arm') { + # Stack protector disabled on ia64, alpha, hppa, nios2. + # "warning: -fstack-protector not supported for this target" + # Stack protector disabled on arm (ok on armel). + # compiler supports it incorrectly (leads to SEGV) + $use_feature{hardening}{stackprotector} = 0; + } + if (none { $arch eq $_ } qw(amd64 arm64 armhf armel)) { + # Stack clash protector only available on amd64 and arm. + $use_feature{hardening}{stackclash} = 0; + } + if (any { $cpu eq $_ } qw(ia64 hppa)) { + # relro not implemented on ia64, hppa. + $use_feature{hardening}{relro} = 0; + } + if (none { $cpu eq $_ } qw(amd64 arm64)) { + # On amd64 use -fcf-protection. + # On arm64 use -mbranch-protection=standard. + $use_feature{hardening}{branch} = 0; + } + $flags->set_option_value('hardening-branch-cpu', $cpu); + + # Mask features that might be influenced by other flags. + if ($flags->get_option_value('optimize-level') == 0) { + # glibc 2.16 and later warn when using -O0 and _FORTIFY_SOURCE. + $use_feature{hardening}{fortify} = 0; + } + $flags->set_option_value('fortify-level', 2); + + # Handle logical feature interactions. + if ($use_feature{hardening}{relro} == 0) { + # Disable bindnow if relro is not enabled, since it has no + # hardening ability without relro and may incur load penalties. + $use_feature{hardening}{bindnow} = 0; + } + if ($use_feature{hardening}{stackprotector} == 0) { + # Disable stackprotectorstrong if stackprotector is disabled. + $use_feature{hardening}{stackprotectorstrong} = 0; + } + + ## Commit + + # Set used features to their builtin setting if unset. + foreach my $area (sort keys %builtin_feature) { + while (my ($feature, $enabled) = each %{$builtin_feature{$area}}) { + $flags->set_builtin($area, $feature, $enabled); + } + } + + # Store the feature usage. + foreach my $area (sort keys %use_feature) { + while (my ($feature, $enabled) = each %{$use_feature{$area}}) { + $flags->set_feature($area, $feature, $enabled); + } + } +} + +sub _add_build_flags { + my ($self, $flags) = @_; + + ## Global default flags + + my @compile_flags = qw( + CFLAGS + CXXFLAGS + OBJCFLAGS + OBJCXXFLAGS + FFLAGS + FCFLAGS + ); + + my $default_flags; + my $default_d_flags; + + my $optimize_level = $flags->get_option_value('optimize-level'); + $default_flags = "-g -O$optimize_level"; + if ($optimize_level == 0) { + $default_d_flags = '-fdebug'; + } else { + $default_d_flags = '-frelease'; + } + + $flags->append($_, $default_flags) foreach @compile_flags; + $flags->append($_ . '_FOR_BUILD', $default_flags) foreach @compile_flags; + $flags->append('DFLAGS', $default_d_flags); + $flags->append('DFLAGS_FOR_BUILD', $default_d_flags); + + ## Area: abi + + my %abi_builtins = $flags->get_builtins('abi'); + if ($flags->use_feature('abi', 'lfs') && ! $abi_builtins{lfs}) { + $flags->append('CPPFLAGS', + '-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'); + } + + if ($flags->use_feature('abi', 'time64') && ! $abi_builtins{time64}) { + $flags->append('CPPFLAGS', '-D_TIME_BITS=64'); + } + + ## Area: qa + + # Warnings that detect actual bugs. + if ($flags->use_feature('qa', 'bug-implicit-func')) { + $flags->append('CFLAGS', '-Werror=implicit-function-declaration'); + } + if ($flags->use_feature('qa', 'bug')) { + # C/C++ flags + my @cfamilyflags = qw( + array-bounds + clobbered + volatile-register-var + ); + foreach my $warnflag (@cfamilyflags) { + $flags->append('CFLAGS', "-Werror=$warnflag"); + $flags->append('CXXFLAGS', "-Werror=$warnflag"); + } + } + + # Inject dummy canary options to detect issues with build flag propagation. + if ($flags->use_feature('qa', 'canary')) { + require Digest::MD5; + my $id = Digest::MD5::md5_hex(int rand 4096); + + foreach my $flag (qw(CPPFLAGS CFLAGS OBJCFLAGS CXXFLAGS OBJCXXFLAGS)) { + $flags->append($flag, "-D__DEB_CANARY_${flag}_${id}__"); + } + $flags->append('LDFLAGS', "-Wl,-z,deb-canary-${id}"); + } + + ## Area: reproducible + + # Warn when the __TIME__, __DATE__ and __TIMESTAMP__ macros are used. + if ($flags->use_feature('reproducible', 'timeless')) { + $flags->append('CPPFLAGS', '-Wdate-time'); + } + + # Avoid storing the build path in the binaries. + if ($flags->use_feature('reproducible', 'fixfilepath') or + $flags->use_feature('reproducible', 'fixdebugpath')) { + my $build_path = $flags->get_option_value('build-path'); + my $map; + + # -ffile-prefix-map is a superset of -fdebug-prefix-map, prefer it + # if both are set. + if ($flags->use_feature('reproducible', 'fixfilepath')) { + $map = '-ffile-prefix-map=' . $build_path . '=.'; + } else { + $map = '-fdebug-prefix-map=' . $build_path . '=.'; + } + + $flags->append($_, $map) foreach @compile_flags; + } + + ## Area: optimize + + if ($flags->use_feature('optimize', 'lto')) { + my $flag = '-flto=auto -ffat-lto-objects'; + $flags->append($_, $flag) foreach (@compile_flags, 'LDFLAGS'); + } + + ## Area: sanitize + + if ($flags->use_feature('sanitize', 'address')) { + my $flag = '-fsanitize=address -fno-omit-frame-pointer'; + $flags->append('CFLAGS', $flag); + $flags->append('CXXFLAGS', $flag); + $flags->append('LDFLAGS', '-fsanitize=address'); + } + + if ($flags->use_feature('sanitize', 'thread')) { + my $flag = '-fsanitize=thread'; + $flags->append('CFLAGS', $flag); + $flags->append('CXXFLAGS', $flag); + $flags->append('LDFLAGS', $flag); + } + + if ($flags->use_feature('sanitize', 'leak')) { + $flags->append('LDFLAGS', '-fsanitize=leak'); + } + + if ($flags->use_feature('sanitize', 'undefined')) { + my $flag = '-fsanitize=undefined'; + $flags->append('CFLAGS', $flag); + $flags->append('CXXFLAGS', $flag); + $flags->append('LDFLAGS', $flag); + } + + ## Area: hardening + + # PIE + my $use_pie = $flags->get_feature('hardening', 'pie'); + my %hardening_builtins = $flags->get_builtins('hardening'); + if (defined $use_pie && $use_pie && ! $hardening_builtins{pie}) { + my $flag = "-specs=$Dpkg::DATADIR/pie-compile.specs"; + $flags->append($_, $flag) foreach @compile_flags; + $flags->append('LDFLAGS', "-specs=$Dpkg::DATADIR/pie-link.specs"); + } elsif (defined $use_pie && ! $use_pie && $hardening_builtins{pie}) { + my $flag = "-specs=$Dpkg::DATADIR/no-pie-compile.specs"; + $flags->append($_, $flag) foreach @compile_flags; + $flags->append('LDFLAGS', "-specs=$Dpkg::DATADIR/no-pie-link.specs"); + } + + # Stack protector + if ($flags->use_feature('hardening', 'stackprotectorstrong')) { + my $flag = '-fstack-protector-strong'; + $flags->append($_, $flag) foreach @compile_flags; + } elsif ($flags->use_feature('hardening', 'stackprotector')) { + my $flag = '-fstack-protector --param=ssp-buffer-size=4'; + $flags->append($_, $flag) foreach @compile_flags; + } + + # Stack clash + if ($flags->use_feature('hardening', 'stackclash')) { + my $flag = '-fstack-clash-protection'; + $flags->append($_, $flag) foreach @compile_flags; + } + + # Fortify Source + if ($flags->use_feature('hardening', 'fortify')) { + my $fortify_level = $flags->get_option_value('fortify-level'); + $flags->append('CPPFLAGS', "-D_FORTIFY_SOURCE=$fortify_level"); + } + + # Format Security + if ($flags->use_feature('hardening', 'format')) { + my $flag = '-Wformat -Werror=format-security'; + $flags->append('CFLAGS', $flag); + $flags->append('CXXFLAGS', $flag); + $flags->append('OBJCFLAGS', $flag); + $flags->append('OBJCXXFLAGS', $flag); + } + + # Read-only Relocations + if ($flags->use_feature('hardening', 'relro')) { + $flags->append('LDFLAGS', '-Wl,-z,relro'); + } + + # Bindnow + if ($flags->use_feature('hardening', 'bindnow')) { + $flags->append('LDFLAGS', '-Wl,-z,now'); + } + + # Branch protection + if ($flags->use_feature('hardening', 'branch')) { + my $cpu = $flags->get_option_value('hardening-branch-cpu'); + my $flag; + if ($cpu eq 'arm64') { + $flag = '-mbranch-protection=standard'; + } elsif ($cpu eq 'amd64') { + $flag = '-fcf-protection'; + } + $flags->append($_, $flag) foreach @compile_flags; + } +} + +sub _build_tainted_by { + my $self = shift; + my %tainted; + + foreach my $pathname (qw(/bin /sbin /lib /lib32 /libo32 /libx32 /lib64)) { + next unless -l $pathname; + + my $linkname = readlink $pathname; + if ($linkname eq "usr$pathname" or $linkname eq "/usr$pathname") { + $tainted{'merged-usr-via-aliased-dirs'} = 1; + last; + } + } + + require File::Find; + my %usr_local_types = ( + configs => [ qw(etc) ], + includes => [ qw(include) ], + programs => [ qw(bin sbin) ], + libraries => [ qw(lib) ], + ); + foreach my $type (keys %usr_local_types) { + File::Find::find({ + wanted => sub { $tainted{"usr-local-has-$type"} = 1 if -f }, + no_chdir => 1, + }, grep { -d } map { "/usr/local/$_" } @{$usr_local_types{$type}}); + } + + my @tainted = sort keys %tainted; + return @tainted; +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Vendor/Default.pm b/scripts/Dpkg/Vendor/Default.pm new file mode 100644 index 0000000..fc0e6be --- /dev/null +++ b/scripts/Dpkg/Vendor/Default.pm @@ -0,0 +1,231 @@ +# Copyright © 2009 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Vendor::Default - default vendor class + +=head1 DESCRIPTION + +A vendor class is used to provide vendor specific behaviour +in various places. This is the default class used in case +there's none for the current vendor or in case the vendor could +not be identified (see L<Dpkg::Vendor> documentation). + +It provides some hooks that are called by various dpkg-* tools. +If you need a new hook, please file a bug against dpkg-dev and explain +your need. Note that the hook API has no guarantee to be stable over an +extended period of time. If you run an important distribution that makes +use of vendor hooks, you'd better submit them for integration so that +we avoid breaking your code. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Vendor::Default 0.01; + +use strict; +use warnings; + +# If you use this file as template to create a new vendor class, please +# uncomment the following lines +#use parent qw(Dpkg::Vendor::Default); + +=head1 METHODS + +=over 4 + +=item $vendor_obj = Dpkg::Vendor::Default->new() + +Creates the default vendor object. Can be inherited by all vendor objects +if they don't need any specific initialization at object creation time. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = {}; + bless $self, $class; + return $self; +} + +=item $vendor_obj->run_hook($id, @params) + +Run the corresponding hook. The parameters are hook-specific. The +supported hooks are: + +=over 8 + +=item before-source-build ($srcpkg) + +The first parameter is a L<Dpkg::Source::Package> object. The hook is called +just before the execution of $srcpkg->build(). + +=item package-keyrings () + +The hook is called when dpkg-source is checking a signature on a source +package (since dpkg 1.18.11). It takes no parameters, but returns a +(possibly empty) list of vendor-specific keyrings. + +=item archive-keyrings () + +The hook is called when there is a need to check signatures on artifacts +from repositories, for example by a download method (since dpkg 1.18.11). +It takes no parameters, but returns a (possibly empty) list of +vendor-specific keyrings. + +=item archive-keyrings-historic () + +The hook is called when there is a need to check signatures on artifacts +from historic repositories, for example by a download method +(since dpkg 1.18.11). It takes no parameters, but returns a (possibly empty) +list of vendor-specific keyrings. + +=item builtin-build-depends () + +The hook is called when dpkg-checkbuilddeps is initializing the source +package build dependencies (since dpkg 1.18.2). It takes no parameters, +but returns a (possibly empty) list of vendor-specific B<Build-Depends>. + +=item builtin-build-conflicts () + +The hook is called when dpkg-checkbuilddeps is initializing the source +package build conflicts (since dpkg 1.18.2). It takes no parameters, +but returns a (possibly empty) list of vendor-specific B<Build-Conflicts>. + +=item register-custom-fields () + +The hook is called in L<Dpkg::Control::Fields> to register custom fields. +You should return a list of arrays. Each array is an operation to perform. +The first item is the name of the operation and corresponds +to a field_* function provided by L<Dpkg::Control::Fields>. The remaining +fields are the parameters that are passed unchanged to the corresponding +function. + +Known operations are "register", "insert_after" and "insert_before". + +=item post-process-changelog-entry ($fields) + +The hook is called in L<Dpkg::Changelog> to post-process a +L<Dpkg::Changelog::Entry> after it has been created and filled with the +appropriate values. + +=item update-buildflags ($flags) + +The hook is called in L<Dpkg::BuildFlags> to allow the vendor to override +the default values set for the various build flags. $flags is a +L<Dpkg::BuildFlags> object. + +=item builtin-system-build-paths () + +The hook is called by dpkg-genbuildinfo to determine if the current path +should be recorded in the B<Build-Path> field (since dpkg 1.18.11). It takes +no parameters, but returns a (possibly empty) list of root paths considered +acceptable. As an example, if the list contains "/build/", a Build-Path +field will be created if the current directory is "/build/dpkg-1.18.0". If +the list contains "/", the path will always be recorded. If the list is +empty, the current path will never be recorded. + +=item build-tainted-by () + +The hook is called by dpkg-genbuildinfo to determine if the current system +has been tainted in some way that could affect the resulting build, which +will be recorded in the B<Build-Tainted-By> field (since dpkg 1.19.5). It +takes no parameters, but returns a (possibly empty) list of tainted reason +tags (formed by alphanumeric and dash characters). + +=item sanitize-environment () + +The hook is called by dpkg-buildpackage to sanitize its build environment +(since dpkg 1.20.0). + +=item backport-version-regex () + +The hook is called by dpkg-genchanges and dpkg-mergechangelog to determine +the backport version string that should be specially handled as not an earlier +than version or remapped so that it does not get considered as a pre-release +(since dpkg 1.21.3). +The returned string is a regex with one capture group for the backport +delimiter string, or undef if there is no regex. + +=back + +=cut + +sub run_hook { + my ($self, $hook, @params) = @_; + + if ($hook eq 'before-source-build') { + my $srcpkg = shift @params; + } elsif ($hook eq 'package-keyrings') { + return (); + } elsif ($hook eq 'archive-keyrings') { + return (); + } elsif ($hook eq 'archive-keyrings-historic') { + return (); + } elsif ($hook eq 'register-custom-fields') { + return (); + } elsif ($hook eq 'builtin-build-depends') { + return (); + } elsif ($hook eq 'builtin-build-conflicts') { + return (); + } elsif ($hook eq 'post-process-changelog-entry') { + my $fields = shift @params; + } elsif ($hook eq 'extend-patch-header') { + my ($textref, $ch_info) = @params; + } elsif ($hook eq 'update-buildflags') { + my $flags = shift @params; + } elsif ($hook eq 'builtin-system-build-paths') { + return (); + } elsif ($hook eq 'build-tainted-by') { + return (); + } elsif ($hook eq 'sanitize-environment') { + return; + } elsif ($hook eq 'backport-version-regex') { + return; + } + + # Default return value for unknown/unimplemented hooks + return; +} + +=item $vendor->set_build_features($flags) + +Sets the vendor build features, which will then be used to initialize the +build flags. + +=cut + +sub set_build_features { + my ($self, $flags) = @_; + + return; +} + +=back + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Vendor/Devuan.pm b/scripts/Dpkg/Vendor/Devuan.pm new file mode 100644 index 0000000..1ff5adf --- /dev/null +++ b/scripts/Dpkg/Vendor/Devuan.pm @@ -0,0 +1,68 @@ +# Copyright © 2022 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Vendor::Devuan - Devuan vendor class + +=head1 DESCRIPTION + +This vendor class customizes the behavior of dpkg scripts for Devuan +specific behavior and policies. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Vendor::Devuan 0.01; + +use strict; +use warnings; + +use parent qw(Dpkg::Vendor::Debian); + +sub run_hook { + my ($self, $hook, @params) = @_; + + if ($hook eq 'package-keyrings') { + return ('/usr/share/keyrings/devuan-keyring.gpg', + '/usr/share/keyrings/devuan-maintainers.gpg'); + } elsif ($hook eq 'archive-keyrings') { + return ('/usr/share/keyrings/devuan-archive-keyring.gpg'); + } elsif ($hook eq 'archive-keyrings-historic') { + return ('/usr/share/keyrings/devuan-archive-removed-keys.gpg'); + } elsif ($hook eq 'extend-patch-header') { + my ($textref, $ch_info) = @params; + if ($ch_info->{'Closes'}) { + foreach my $bug (split(/\s+/, $ch_info->{'Closes'})) { + $$textref .= "Bug-Devuan: https://bugs.devuan.org/$bug\n"; + } + } + } else { + return $self->SUPER::run_hook($hook, @params); + } +} + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; diff --git a/scripts/Dpkg/Vendor/Ubuntu.pm b/scripts/Dpkg/Vendor/Ubuntu.pm new file mode 100644 index 0000000..b50da37 --- /dev/null +++ b/scripts/Dpkg/Vendor/Ubuntu.pm @@ -0,0 +1,176 @@ +# Copyright © 2008 Ian Jackson <ijackson@chiark.greenend.org.uk> +# Copyright © 2008 Canonical, Ltd. +# written by Colin Watson <cjwatson@ubuntu.com> +# Copyright © 2008 James Westby <jw+debian@jameswestby.net> +# Copyright © 2009 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Vendor::Ubuntu - Ubuntu vendor class + +=head1 DESCRIPTION + +This vendor class customizes the behavior of dpkg scripts for Ubuntu +specific behavior and policies. + +B<Note>: This is a private module, its API can change at any time. + +=cut + +package Dpkg::Vendor::Ubuntu 0.01; + +use strict; +use warnings; + +use List::Util qw(any); + +use Dpkg::ErrorHandling; +use Dpkg::Gettext; +use Dpkg::Control::Types; + +use parent qw(Dpkg::Vendor::Debian); + +sub run_hook { + my ($self, $hook, @params) = @_; + + if ($hook eq 'before-source-build') { + my $src = shift @params; + my $fields = $src->{fields}; + + # check that Maintainer/XSBC-Original-Maintainer comply to + # https://wiki.ubuntu.com/DebianMaintainerField + if (defined($fields->{'Version'}) and defined($fields->{'Maintainer'}) and + $fields->{'Version'} =~ /ubuntu/) { + if ($fields->{'Maintainer'} !~ /(?:ubuntu|canonical)/i) { + if (length $ENV{DEBEMAIL} and $ENV{DEBEMAIL} =~ /\@(?:ubuntu|canonical)\.com/) { + error(g_('Version number suggests Ubuntu changes, but Maintainer: does not have Ubuntu address')); + } else { + warning(g_('Version number suggests Ubuntu changes, but Maintainer: does not have Ubuntu address')); + } + } + unless ($fields->{'Original-Maintainer'}) { + warning(g_('Version number suggests Ubuntu changes, but there is no XSBC-Original-Maintainer field')); + } + } + } elsif ($hook eq 'package-keyrings') { + return ($self->SUPER::run_hook($hook), + '/usr/share/keyrings/ubuntu-archive-keyring.gpg'); + } elsif ($hook eq 'archive-keyrings') { + return ($self->SUPER::run_hook($hook), + '/usr/share/keyrings/ubuntu-archive-keyring.gpg'); + } elsif ($hook eq 'archive-keyrings-historic') { + return ($self->SUPER::run_hook($hook), + '/usr/share/keyrings/ubuntu-archive-removed-keys.gpg'); + } elsif ($hook eq 'register-custom-fields') { + my @field_ops = $self->SUPER::run_hook($hook); + push @field_ops, [ + 'register', 'Launchpad-Bugs-Fixed', + CTRL_FILE_CHANGES | CTRL_CHANGELOG, + ], [ + 'insert_after', CTRL_FILE_CHANGES, 'Closes', 'Launchpad-Bugs-Fixed', + ], [ + 'insert_after', CTRL_CHANGELOG, 'Closes', 'Launchpad-Bugs-Fixed', + ]; + return @field_ops; + } elsif ($hook eq 'post-process-changelog-entry') { + my $fields = shift @params; + + # Add Launchpad-Bugs-Fixed field + my $bugs = find_launchpad_closes($fields->{'Changes'} // ''); + if (scalar(@$bugs)) { + $fields->{'Launchpad-Bugs-Fixed'} = join(' ', @$bugs); + } + } elsif ($hook eq 'update-buildflags') { + my $flags = shift @params; + + # Run the Debian hook to add hardening flags + $self->SUPER::run_hook($hook, $flags); + + # Per https://wiki.ubuntu.com/DistCompilerFlags + $flags->prepend('LDFLAGS', '-Wl,-Bsymbolic-functions'); + } else { + return $self->SUPER::run_hook($hook, @params); + } +} + +# Override Debian default features. +sub init_build_features { + my ($self, $use_feature, $builtin_feature) = @_; + + $self->SUPER::init_build_features($use_feature, $builtin_feature); + + require Dpkg::Arch; + my $arch = Dpkg::Arch::get_host_arch(); + + if (any { $_ eq $arch } qw(amd64 arm64 ppc64el s390x)) { + $use_feature->{optimize}{lto} = 1; + } +} + +sub set_build_features { + my ($self, $flags) = @_; + + $self->SUPER::set_build_features($flags); + + require Dpkg::Arch; + my $arch = Dpkg::Arch::get_host_arch(); + + if ($arch eq 'ppc64el' && $flags->get_option_value('optimize-level') != 0) { + $flags->set_option_value('optimize-level', 3); + } + + $flags->set_option_value('fortify-level', 3); +} + +=head1 PUBLIC FUNCTIONS + +=over + +=item $bugs = Dpkg::Vendor::Ubuntu::find_launchpad_closes($changes) + +Takes one string as argument and finds "LP: #123456, #654321" statements, +which are references to bugs on Launchpad. Returns all closed bug +numbers in an array reference. + +=cut + +sub find_launchpad_closes { + my $changes = shift; + my %closes; + + while ($changes && + ($changes =~ /lp:\s+\#\d+(?:,\s*\#\d+)*/pig)) { + $closes{$_} = 1 foreach (${^MATCH} =~ /\#?\s?(\d+)/g); + } + + my @closes = sort { $a <=> $b } keys %closes; + + return \@closes; +} + +=back + +=head1 CHANGES + +=head2 Version 0.xx + +This is a semi-private module. Only documented functions are public. + +=cut + +1; diff --git a/scripts/Dpkg/Version.pm b/scripts/Dpkg/Version.pm new file mode 100644 index 0000000..e045ad0 --- /dev/null +++ b/scripts/Dpkg/Version.pm @@ -0,0 +1,494 @@ +# Copyright © Colin Watson <cjwatson@debian.org> +# Copyright © Ian Jackson <ijackson@chiark.greenend.org.uk> +# Copyright © 2007 Don Armstrong <don@donarmstrong.com>. +# Copyright © 2009 Raphaël Hertzog <hertzog@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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Version - handling and comparing dpkg-style version numbers + +=head1 DESCRIPTION + +The Dpkg::Version module provides pure-Perl routines to compare +dpkg-style version numbers (as used in Debian packages) and also +an object oriented interface overriding perl operators +to do the right thing when you compare Dpkg::Version object between +them. + +=cut + +package Dpkg::Version 1.03; + +use strict; +use warnings; +# Currently unused, but not removed to not generate warnings on users. +use warnings::register qw(semantic_change::overload::bool); + +our @EXPORT = qw( + version_compare + version_compare_relation + version_normalize_relation + version_compare_string + version_compare_part + version_split_digits + version_check + REL_LT + REL_LE + REL_EQ + REL_GE + REL_GT +); + +use Exporter qw(import); +use Carp; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +use constant { + REL_LT => '<<', + REL_LE => '<=', + REL_EQ => '=', + REL_GE => '>=', + REL_GT => '>>', +}; + +use overload + '<=>' => \&_comparison, + 'cmp' => \&_comparison, + '""' => sub { return $_[0]->as_string(); }, + 'bool' => sub { return $_[0]->is_valid(); }, + 'fallback' => 1; + +=head1 METHODS + +=over 4 + +=item $v = Dpkg::Version->new($version, %opts) + +Create a new Dpkg::Version object corresponding to the version indicated in +the string (scalar) $version. By default it will accepts any string +and consider it as a valid version. If you pass the option "check => 1", +it will return undef if the version is invalid (see version_check for +details). + +You can always call $v->is_valid() later on to verify that the version is +valid. + +=cut + +sub new { + my ($this, $ver, %opts) = @_; + my $class = ref($this) || $this; + $ver = "$ver" if ref($ver); # Try to stringify objects + + if ($opts{check}) { + return unless version_check($ver); + } + + my $self = {}; + if ($ver =~ /^([^:]*):(.+)$/) { + $self->{epoch} = $1; + $ver = $2; + } else { + $self->{epoch} = 0; + $self->{no_epoch} = 1; + } + if ($ver =~ /(.*)-(.*)$/) { + $self->{version} = $1; + $self->{revision} = $2; + } else { + $self->{version} = $ver; + $self->{revision} = 0; + $self->{no_revision} = 1; + } + + return bless $self, $class; +} + +=item boolean evaluation + +When the Dpkg::Version object is used in a boolean evaluation (for example +in "if ($v)" or "$v ? \"$v\" : 'default'") it returns true if the version +stored is valid ($v->is_valid()) and false otherwise. + +B<Notice>: Between dpkg 1.15.7.2 and 1.19.1 this overload used to return +$v->as_string() if $v->is_valid(), a breaking change in behavior that caused +"0" versions to be evaluated as false. To catch any possibly intended code +that relied on those semantics, this overload emitted a warning with category +"Dpkg::Version::semantic_change::overload::bool" between dpkg 1.19.1 and +1.20.0. Once fixed, or for already valid code the warning could be quiesced +for that specific versions with + + no if $Dpkg::Version::VERSION eq '1.02', + warnings => qw(Dpkg::Version::semantic_change::overload::bool); + +added after the C<use Dpkg::Version>. + +=item $v->is_valid() + +Returns true if the version is valid, false otherwise. + +=cut + +sub is_valid { + my $self = shift; + return scalar version_check($self); +} + +=item $v->epoch(), $v->version(), $v->revision() + +Returns the corresponding part of the full version string. + +=cut + +sub epoch { + my $self = shift; + return $self->{epoch}; +} + +sub version { + my $self = shift; + return $self->{version}; +} + +sub revision { + my $self = shift; + return $self->{revision}; +} + +=item $v->is_native() + +Returns true if the version is native, false if it has a revision. + +=cut + +sub is_native { + my $self = shift; + return $self->{no_revision}; +} + +=item $v1 <=> $v2, $v1 < $v2, $v1 <= $v2, $v1 > $v2, $v1 >= $v2 + +Numerical comparison of various versions numbers. One of the two operands +needs to be a Dpkg::Version, the other one can be anything provided that +its string representation is a version number. + +=cut + +sub _comparison { + my ($a, $b, $inverted) = @_; + if (not ref($b) or not $b->isa('Dpkg::Version')) { + $b = Dpkg::Version->new($b); + } + ($a, $b) = ($b, $a) if $inverted; + my $r = version_compare_part($a->epoch(), $b->epoch()); + return $r if $r; + $r = version_compare_part($a->version(), $b->version()); + return $r if $r; + return version_compare_part($a->revision(), $b->revision()); +} + +=item "$v", $v->as_string(), $v->as_string(%options) + +Accepts an optional option hash reference, affecting the string conversion. + +Options: + +=over 8 + +=item omit_epoch (defaults to 0) + +Omit the epoch, if present, in the output string. + +=item omit_revision (defaults to 0) + +Omit the revision, if present, in the output string. + +=back + +Returns the string representation of the version number. + +=cut + +sub as_string { + my ($self, %opts) = @_; + my $no_epoch = $opts{omit_epoch} || $self->{no_epoch}; + my $no_revision = $opts{omit_revision} || $self->{no_revision}; + + my $str = ''; + $str .= $self->{epoch} . ':' unless $no_epoch; + $str .= $self->{version}; + $str .= '-' . $self->{revision} unless $no_revision; + return $str; +} + +=back + +=head1 FUNCTIONS + +All the functions are exported by default. + +=over 4 + +=item version_compare($a, $b) + +Returns -1 if $a is earlier than $b, 0 if they are equal and 1 if $a +is later than $b. + +If $a or $b are not valid version numbers, it dies with an error. + +=cut + +sub version_compare($$) { + my ($a, $b) = @_; + my $va = Dpkg::Version->new($a, check => 1); + defined($va) || error(g_('%s is not a valid version'), "$a"); + my $vb = Dpkg::Version->new($b, check => 1); + defined($vb) || error(g_('%s is not a valid version'), "$b"); + return $va <=> $vb; +} + +=item version_compare_relation($a, $rel, $b) + +Returns the result (0 or 1) of the given comparison operation. This +function is implemented on top of version_compare(). + +Allowed values for $rel are the exported constants REL_GT, REL_GE, +REL_EQ, REL_LE, REL_LT. Use version_normalize_relation() if you +have an input string containing the operator. + +=cut + +sub version_compare_relation($$$) { + my ($a, $op, $b) = @_; + my $res = version_compare($a, $b); + + if ($op eq REL_GT) { + return $res > 0; + } elsif ($op eq REL_GE) { + return $res >= 0; + } elsif ($op eq REL_EQ) { + return $res == 0; + } elsif ($op eq REL_LE) { + return $res <= 0; + } elsif ($op eq REL_LT) { + return $res < 0; + } else { + croak "unsupported relation for version_compare_relation(): '$op'"; + } +} + +=item $rel = version_normalize_relation($rel_string) + +Returns the normalized constant of the relation $rel (a value +among REL_GT, REL_GE, REL_EQ, REL_LE and REL_LT). Supported +relations names in input are: "gt", "ge", "eq", "le", "lt", ">>", ">=", +"=", "<=", "<<". ">" and "<" are also supported but should not be used as +they are obsolete aliases of ">=" and "<=". + +=cut + +sub version_normalize_relation($) { + my $op = shift; + + warning('relation %s is deprecated: use %s or %s', + $op, "$op$op", "$op=") if ($op eq '>' or $op eq '<'); + + if ($op eq '>>' or $op eq 'gt') { + return REL_GT; + } elsif ($op eq '>=' or $op eq 'ge' or $op eq '>') { + return REL_GE; + } elsif ($op eq '=' or $op eq 'eq') { + return REL_EQ; + } elsif ($op eq '<=' or $op eq 'le' or $op eq '<') { + return REL_LE; + } elsif ($op eq '<<' or $op eq 'lt') { + return REL_LT; + } else { + croak "bad relation '$op'"; + } +} + +=item version_compare_string($a, $b) + +String comparison function used for comparing non-numerical parts of version +numbers. Returns -1 if $a is earlier than $b, 0 if they are equal and 1 if $a +is later than $b. + +The "~" character always sort lower than anything else. Digits sort lower +than non-digits. Among remaining characters alphabetic characters (A-Z, a-z) +sort lower than the other ones. Within each range, the ASCII decimal value +of the character is used to sort between characters. + +=cut + +sub _version_order { + my $x = shift; + + if ($x eq '~') { + return -1; + } elsif ($x =~ /^\d$/) { + return $x * 1 + 1; + } elsif ($x =~ /^[A-Za-z]$/) { + return ord($x); + } else { + return ord($x) + 256; + } +} + +sub version_compare_string($$) { + my @a = map { _version_order($_) } split(//, shift); + my @b = map { _version_order($_) } split(//, shift); + while (1) { + my ($a, $b) = (shift @a, shift @b); + return 0 if not defined($a) and not defined($b); + $a ||= 0; # Default order for "no character" + $b ||= 0; + return 1 if $a > $b; + return -1 if $a < $b; + } +} + +=item version_compare_part($a, $b) + +Compare two corresponding sub-parts of a version number (either upstream +version or debian revision). + +Each parameter is split by version_split_digits() and resulting items +are compared together. As soon as a difference happens, it returns -1 if +$a is earlier than $b, 0 if they are equal and 1 if $a is later than $b. + +=cut + +sub version_compare_part($$) { + my @a = version_split_digits(shift); + my @b = version_split_digits(shift); + while (1) { + my ($a, $b) = (shift @a, shift @b); + return 0 if not defined($a) and not defined($b); + $a ||= 0; # Default value for lack of version + $b ||= 0; + if ($a =~ /^\d+$/ and $b =~ /^\d+$/) { + # Numerical comparison + my $cmp = $a <=> $b; + return $cmp if $cmp; + } else { + # String comparison + my $cmp = version_compare_string($a, $b); + return $cmp if $cmp; + } + } +} + +=item @items = version_split_digits($version) + +Splits a string in items that are each entirely composed either +of digits or of non-digits. For instance for "1.024~beta1+svn234" it would +return ("1", ".", "024", "~beta", "1", "+svn", "234"). + +=cut + +sub version_split_digits($) { + my $version = shift; + + return split /(?<=\d)(?=\D)|(?<=\D)(?=\d)/, $version; +} + +=item ($ok, $msg) = version_check($version) + +=item $ok = version_check($version) + +Checks the validity of $version as a version number. Returns 1 in $ok +if the version is valid, 0 otherwise. In the latter case, $msg +contains a description of the problem with the $version scalar. + +=cut + +sub version_check($) { + my $version = shift; + my $str; + if (defined $version) { + $str = "$version"; + $version = Dpkg::Version->new($str) unless ref($version); + } + if (not defined($str) or not length($str)) { + my $msg = g_('version number cannot be empty'); + return (0, $msg) if wantarray; + return 0; + } + if (not defined $version->epoch() or not length $version->epoch()) { + my $msg = sprintf(g_('epoch part of the version number cannot be empty')); + return (0, $msg) if wantarray; + return 0; + } + if (not defined $version->version() or not length $version->version()) { + my $msg = g_('upstream version cannot be empty'); + return (0, $msg) if wantarray; + return 0; + } + if (not defined $version->revision() or not length $version->revision()) { + my $msg = sprintf(g_('revision cannot be empty')); + return (0, $msg) if wantarray; + return 0; + } + if ($version->version() =~ m/^[^\d]/) { + my $msg = g_('version number does not start with digit'); + return (0, $msg) if wantarray; + return 0; + } + if ($str =~ m/([^-+:.0-9a-zA-Z~])/o) { + my $msg = sprintf g_("version number contains illegal character '%s'"), $1; + return (0, $msg) if wantarray; + return 0; + } + if ($version->epoch() !~ /^\d*$/) { + my $msg = sprintf(g_('epoch part of the version number ' . + "is not a number: '%s'"), $version->epoch()); + return (0, $msg) if wantarray; + return 0; + } + return (1, '') if wantarray; + return 1; +} + +=back + +=head1 CHANGES + +=head2 Version 1.03 (dpkg 1.20.0) + +Remove deprecation warning from semantic change in 1.02. + +=head2 Version 1.02 (dpkg 1.19.1) + +Semantic change: bool evaluation semantics restored to their original behavior. + +=head2 Version 1.01 (dpkg 1.17.0) + +New argument: Accept an options argument in $v->as_string(). + +New method: $v->is_native(). + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; |