summaryrefslogtreecommitdiffstats
path: root/scripts/Dpkg
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 14:58:51 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 14:58:51 +0000
commitcbffab246997fb5a06211dfb706b54e5ae5bb59f (patch)
tree0573c5d96f58d74d76a49c0f2a70398e389a36d3 /scripts/Dpkg
parentInitial commit. (diff)
downloaddpkg-cbffab246997fb5a06211dfb706b54e5ae5bb59f.tar.xz
dpkg-cbffab246997fb5a06211dfb706b54e5ae5bb59f.zip
Adding upstream version 1.21.22.upstream/1.21.22upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to '')
-rw-r--r--scripts/Dpkg.pm307
-rw-r--r--scripts/Dpkg/Arch.pm707
-rw-r--r--scripts/Dpkg/Build/Info.pm97
-rw-r--r--scripts/Dpkg/BuildEnv.pm113
-rw-r--r--scripts/Dpkg/BuildFlags.pm612
-rw-r--r--scripts/Dpkg/BuildInfo.pm154
-rw-r--r--scripts/Dpkg/BuildOptions.pm246
-rw-r--r--scripts/Dpkg/BuildProfiles.pm146
-rw-r--r--scripts/Dpkg/BuildTypes.pm284
-rw-r--r--scripts/Dpkg/Changelog.pm775
-rw-r--r--scripts/Dpkg/Changelog/Debian.pm271
-rw-r--r--scripts/Dpkg/Changelog/Entry.pm324
-rw-r--r--scripts/Dpkg/Changelog/Entry/Debian.pm462
-rw-r--r--scripts/Dpkg/Changelog/Parse.pm197
-rw-r--r--scripts/Dpkg/Checksums.pm430
-rw-r--r--scripts/Dpkg/Compression.pm448
-rw-r--r--scripts/Dpkg/Compression/FileHandle.pm473
-rw-r--r--scripts/Dpkg/Compression/Process.pm208
-rw-r--r--scripts/Dpkg/Conf.pm269
-rw-r--r--scripts/Dpkg/Control.pm269
-rw-r--r--scripts/Dpkg/Control/Changelog.pm65
-rw-r--r--scripts/Dpkg/Control/Fields.pm69
-rw-r--r--scripts/Dpkg/Control/FieldsCore.pm1377
-rw-r--r--scripts/Dpkg/Control/Hash.pm48
-rw-r--r--scripts/Dpkg/Control/HashCore.pm589
-rw-r--r--scripts/Dpkg/Control/Info.pm227
-rw-r--r--scripts/Dpkg/Control/Tests.pm83
-rw-r--r--scripts/Dpkg/Control/Tests/Entry.pm94
-rw-r--r--scripts/Dpkg/Control/Types.pm102
-rw-r--r--scripts/Dpkg/Deps.pm490
-rw-r--r--scripts/Dpkg/Deps/AND.pm182
-rw-r--r--scripts/Dpkg/Deps/KnownFacts.pm218
-rw-r--r--scripts/Dpkg/Deps/Multiple.pm250
-rw-r--r--scripts/Dpkg/Deps/OR.pm174
-rw-r--r--scripts/Dpkg/Deps/Simple.pm668
-rw-r--r--scripts/Dpkg/Deps/Union.pm119
-rw-r--r--scripts/Dpkg/Dist/Files.pm198
-rw-r--r--scripts/Dpkg/ErrorHandling.pm263
-rw-r--r--scripts/Dpkg/Exit.pm132
-rw-r--r--scripts/Dpkg/File.pm79
-rw-r--r--scripts/Dpkg/Getopt.pm48
-rw-r--r--scripts/Dpkg/Gettext.pm235
-rw-r--r--scripts/Dpkg/IPC.pm420
-rw-r--r--scripts/Dpkg/Index.pm457
-rw-r--r--scripts/Dpkg/Interface/Storable.pm163
-rw-r--r--scripts/Dpkg/Lock.pm61
-rw-r--r--scripts/Dpkg/OpenPGP.pm155
-rw-r--r--scripts/Dpkg/OpenPGP/Backend.pm127
-rw-r--r--scripts/Dpkg/OpenPGP/Backend/GnuPG.pm301
-rw-r--r--scripts/Dpkg/OpenPGP/Backend/SOP.pm108
-rw-r--r--scripts/Dpkg/OpenPGP/Backend/Sequoia.pm123
-rw-r--r--scripts/Dpkg/OpenPGP/ErrorCodes.pm93
-rw-r--r--scripts/Dpkg/OpenPGP/KeyHandle.pm103
-rw-r--r--scripts/Dpkg/Package.pm47
-rw-r--r--scripts/Dpkg/Path.pm354
-rw-r--r--scripts/Dpkg/Shlibs.pm184
-rw-r--r--scripts/Dpkg/Shlibs/Cppfilt.pm120
-rw-r--r--scripts/Dpkg/Shlibs/Objdump.pm582
-rw-r--r--scripts/Dpkg/Shlibs/Symbol.pm531
-rw-r--r--scripts/Dpkg/Shlibs/SymbolFile.pm697
-rw-r--r--scripts/Dpkg/Source/Archive.pm240
-rw-r--r--scripts/Dpkg/Source/BinaryFiles.pm161
-rw-r--r--scripts/Dpkg/Source/Format.pm191
-rw-r--r--scripts/Dpkg/Source/Functions.pm124
-rw-r--r--scripts/Dpkg/Source/Package.pm741
-rw-r--r--scripts/Dpkg/Source/Package/V1.pm512
-rw-r--r--scripts/Dpkg/Source/Package/V2.pm744
-rw-r--r--scripts/Dpkg/Source/Package/V3/Bzr.pm213
-rw-r--r--scripts/Dpkg/Source/Package/V3/Custom.pm74
-rw-r--r--scripts/Dpkg/Source/Package/V3/Git.pm283
-rw-r--r--scripts/Dpkg/Source/Package/V3/Native.pm121
-rw-r--r--scripts/Dpkg/Source/Package/V3/Quilt.pm269
-rw-r--r--scripts/Dpkg/Source/Patch.pm697
-rw-r--r--scripts/Dpkg/Source/Quilt.pm383
-rw-r--r--scripts/Dpkg/Substvars.pm501
-rw-r--r--scripts/Dpkg/Vars.pm53
-rw-r--r--scripts/Dpkg/Vendor.pm289
-rw-r--r--scripts/Dpkg/Vendor/Debian.pm522
-rw-r--r--scripts/Dpkg/Vendor/Default.pm229
-rw-r--r--scripts/Dpkg/Vendor/Devuan.pm68
-rw-r--r--scripts/Dpkg/Vendor/Ubuntu.pm174
-rw-r--r--scripts/Dpkg/Version.pm491
82 files changed, 24208 insertions, 0 deletions
diff --git a/scripts/Dpkg.pm b/scripts/Dpkg.pm
new file mode 100644
index 0000000..edb0d32
--- /dev/null
+++ b/scripts/Dpkg.pm
@@ -0,0 +1,307 @@
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+package Dpkg;
+
+=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
+
+use strict;
+use warnings;
+
+our $VERSION = '2.00';
+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.21.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..3d8d095
--- /dev/null
+++ b/scripts/Dpkg/Arch.pm
@@ -0,0 +1,707 @@
+# Copyright © 2006-2015 Guillem Jover <guillem@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+package Dpkg::Arch;
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Arch - handle architectures
+
+=head1 DESCRIPTION
+
+The Dpkg::Arch module provides functions to handle Debian architectures,
+wildcards, and mapping from and to GNU triplets.
+
+No symbols are exported by default. The :all tag can be used to import all
+symbols. The :getters, :parsers, :mappers and :operators tags can be used
+to import specific symbol subsets.
+
+=cut
+
+use strict;
+use warnings;
+use feature qw(state);
+
+our $VERSION = '1.03';
+our @EXPORT_OK = qw(
+ get_raw_build_arch
+ get_raw_host_arch
+ get_build_arch
+ get_host_arch
+ get_host_gnu_type
+ get_valid_arches
+ debarch_eq
+ debarch_is
+ debarch_is_wildcard
+ debarch_is_illegal
+ debarch_is_concerned
+ debarch_to_abiattrs
+ debarch_to_cpubits
+ debarch_to_gnutriplet
+ debarch_to_debtuple
+ debarch_to_multiarch
+ debarch_list_parse
+ debtuple_to_debarch
+ debtuple_to_gnutriplet
+ gnutriplet_to_debarch
+ gnutriplet_to_debtuple
+ gnutriplet_to_multiarch
+);
+our %EXPORT_TAGS = (
+ all => [ @EXPORT_OK ],
+ getters => [ qw(
+ get_raw_build_arch
+ get_raw_host_arch
+ get_build_arch
+ get_host_arch
+ get_host_gnu_type
+ get_valid_arches
+ ) ],
+ parsers => [ qw(
+ debarch_list_parse
+ ) ],
+ mappers => [ qw(
+ debarch_to_abiattrs
+ debarch_to_gnutriplet
+ debarch_to_debtuple
+ debarch_to_multiarch
+ debtuple_to_debarch
+ debtuple_to_gnutriplet
+ gnutriplet_to_debarch
+ gnutriplet_to_debtuple
+ gnutriplet_to_multiarch
+ ) ],
+ operators => [ qw(
+ debarch_eq
+ debarch_is
+ debarch_is_wildcard
+ debarch_is_illegal
+ debarch_is_concerned
+ ) ],
+);
+
+
+use Exporter qw(import);
+use List::Util qw(any);
+
+use Dpkg ();
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::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 (undef, undef, undef, $cpu) = debarch_to_debtuple($arch);
+
+ if (defined $cpu) {
+ return $cpubits{$cpu};
+ } else {
+ return;
+ }
+}
+
+=item $bool = debarch_eq($arch_a, $arch_b)
+
+Evaluate the equality of a Debian architecture, by comparing with another
+Debian architecture. No wildcard matching is performed.
+
+=cut
+
+sub debarch_eq($$)
+{
+ my ($a, $b) = @_;
+
+ return 1 if ($a eq $b);
+
+ my @a = debarch_to_debtuple($a);
+ my @b = debarch_to_debtuple($b);
+
+ return 0 if scalar @a != 4 or scalar @b != 4;
+
+ return $a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2] && $a[3] eq $b[3];
+}
+
+=item $bool = debarch_is($arch, $arch_wildcard)
+
+Evaluate the identity of a Debian architecture, by matching with an
+architecture wildcard.
+
+=cut
+
+sub debarch_is($$)
+{
+ my ($real, $alias) = @_;
+
+ return 1 if ($alias eq $real or $alias eq 'any');
+
+ my @real = debarch_to_debtuple($real);
+ my @alias = debwildcard_to_debtuple($alias);
+
+ return 0 if scalar @real != 4 or scalar @alias != 4;
+
+ if (($alias[0] eq $real[0] || $alias[0] eq 'any') &&
+ ($alias[1] eq $real[1] || $alias[1] eq 'any') &&
+ ($alias[2] eq $real[2] || $alias[2] eq 'any') &&
+ ($alias[3] eq $real[3] || $alias[3] eq 'any')) {
+ return 1;
+ }
+
+ return 0;
+}
+
+=item $bool = debarch_is_wildcard($arch)
+
+Evaluate whether a Debian architecture is an architecture wildcard.
+
+=cut
+
+sub debarch_is_wildcard($)
+{
+ my $arch = shift;
+
+ return 0 if $arch eq 'all';
+
+ my @tuple = debwildcard_to_debtuple($arch);
+
+ return 0 if scalar @tuple != 4;
+ return 1 if any { $_ eq 'any' } @tuple;
+ return 0;
+}
+
+=item $bool = debarch_is_illegal($arch, %options)
+
+Validate an architecture name.
+
+If the "positive" option is set to a true value, only positive architectures
+will be accepted, otherwise negated architectures are allowed.
+
+=cut
+
+sub debarch_is_illegal
+{
+ my ($arch, %opts) = @_;
+ my $arch_re = qr/[a-zA-Z0-9][a-zA-Z0-9-]*/;
+
+ if ($opts{positive}) {
+ return $arch !~ m/^$arch_re$/;
+ } else {
+ return $arch !~ m/^!?$arch_re$/;
+ }
+}
+
+=item $bool = debarch_is_concerned($arch, @arches)
+
+Evaluate whether a Debian architecture applies to the list of architecture
+restrictions, as usually found in dependencies inside square brackets.
+
+=cut
+
+sub debarch_is_concerned
+{
+ my ($host_arch, @arches) = @_;
+
+ my $seen_arch = 0;
+ foreach my $arch (@arches) {
+ $arch = lc $arch;
+
+ if ($arch =~ /^!/) {
+ my $not_arch = $arch;
+ $not_arch =~ s/^!//;
+
+ if (debarch_is($host_arch, $not_arch)) {
+ $seen_arch = 0;
+ last;
+ } else {
+ # !arch includes by default all other arches
+ # unless they also appear in a !otherarch
+ $seen_arch = 1;
+ }
+ } elsif (debarch_is($host_arch, $arch)) {
+ $seen_arch = 1;
+ last;
+ }
+ }
+ return $seen_arch;
+}
+
+=item @array = debarch_list_parse($arch_list, %options)
+
+Parse an architecture list.
+
+If the "positive" option is set to a true value, only positive architectures
+will be accepted, otherwise negated architectures are allowed.
+
+=cut
+
+sub debarch_list_parse
+{
+ my ($arch_list, %opts) = @_;
+ my @arch_list = split ' ', $arch_list;
+
+ foreach my $arch (@arch_list) {
+ if (debarch_is_illegal($arch, %opts)) {
+ error(g_("'%s' is not a legal architecture in list '%s'"),
+ $arch, $arch_list);
+ }
+ }
+
+ return @arch_list;
+}
+
+1;
+
+=back
+
+=head1 CHANGES
+
+=head2 Version 1.03 (dpkg 1.19.1)
+
+New argument: Accept a "positive" option in debarch_is_illegal() and
+debarch_list_parse().
+
+=head2 Version 1.02 (dpkg 1.18.19)
+
+New import tags: ":all", ":getters", ":parsers", ":mappers", ":operators".
+
+=head2 Version 1.01 (dpkg 1.18.5)
+
+New functions: debarch_is_illegal(), debarch_list_parse().
+
+=head2 Version 1.00 (dpkg 1.18.2)
+
+Mark the module as public.
+
+=head1 SEE ALSO
+
+dpkg-architecture(1).
diff --git a/scripts/Dpkg/Build/Info.pm b/scripts/Dpkg/Build/Info.pm
new file mode 100644
index 0000000..d789a36
--- /dev/null
+++ b/scripts/Dpkg/Build/Info.pm
@@ -0,0 +1,97 @@
+# 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/>.
+
+package Dpkg::Build::Info;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.02';
+our @EXPORT_OK = qw(
+ get_build_env_whitelist
+ get_build_env_allowed
+);
+
+use Exporter qw(import);
+
+use Dpkg::BuildInfo;
+
+=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 Dpkg::BuildInfo instead.
+
+=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 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/BuildEnv.pm b/scripts/Dpkg/BuildEnv.pm
new file mode 100644
index 0000000..1b6295b
--- /dev/null
+++ b/scripts/Dpkg/BuildEnv.pm
@@ -0,0 +1,113 @@
+# 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/>.
+
+package Dpkg::BuildEnv;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+my %env_modified = ();
+my %env_accessed = ();
+
+=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.
+
+=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..5975bb0
--- /dev/null
+++ b/scripts/Dpkg/BuildFlags.pm
@@ -0,0 +1,612 @@
+# 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/>.
+
+package Dpkg::BuildFlags;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.06';
+
+use Dpkg ();
+use Dpkg::Gettext;
+use Dpkg::BuildEnv;
+use Dpkg::ErrorHandling;
+use Dpkg::Vendor qw(run_vendor_hook);
+
+=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.
+
+=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;
+
+ $self->{features} = {};
+ $self->{builtins} = {};
+ $self->{optvals} = {};
+ $self->{flags} = {
+ ASFLAGS => '',
+ CPPFLAGS => '',
+ CFLAGS => '',
+ CXXFLAGS => '',
+ OBJCFLAGS => '',
+ OBJCXXFLAGS => '',
+ GCJFLAGS => '',
+ DFLAGS => '',
+ FFLAGS => '',
+ FCFLAGS => '',
+ LDFLAGS => '',
+ };
+ $self->{origin} = {
+ ASFLAGS => 'vendor',
+ CPPFLAGS => 'vendor',
+ CFLAGS => 'vendor',
+ CXXFLAGS => 'vendor',
+ OBJCFLAGS => 'vendor',
+ OBJCXXFLAGS => 'vendor',
+ GCJFLAGS => 'vendor',
+ DFLAGS => 'vendor',
+ FFLAGS => 'vendor',
+ FCFLAGS => 'vendor',
+ LDFLAGS => 'vendor',
+ };
+ $self->{maintainer} = {
+ ASFLAGS => 0,
+ CPPFLAGS => 0,
+ CFLAGS => 0,
+ CXXFLAGS => 0,
+ OBJCFLAGS => 0,
+ OBJCXXFLAGS => 0,
+ GCJFLAGS => 0,
+ DFLAGS => 0,
+ FFLAGS => 0,
+ FCFLAGS => 0,
+ LDFLAGS => 0,
+ };
+}
+
+=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
+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
+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 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..7be6bc7
--- /dev/null
+++ b/scripts/Dpkg/BuildInfo.pm
@@ -0,0 +1,154 @@
+# 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/>.
+
+package Dpkg::BuildInfo;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+our @EXPORT_OK = qw(
+ get_build_env_allowed
+);
+
+use Exporter qw(import);
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::BuildInfo - handle build information
+
+=head1 DESCRIPTION
+
+The Dpkg::BuildInfo module provides functions to handle the build
+information.
+
+=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
+ CFLAGS
+ CPPFLAGS
+ CXXFLAGS
+ OBJCFLAGS
+ OBJCXXFLAGS
+ GCJFLAGS
+ DFLAGS
+ FFLAGS
+ LDFLAGS
+ 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..62a84ea
--- /dev/null
+++ b/scripts/Dpkg/BuildOptions.pm
@@ -0,0 +1,246 @@
+# 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/>.
+
+package Dpkg::BuildOptions;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.02';
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::BuildEnv;
+
+=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.
+
+=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;
+ }
+ $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 ($key =~ /^(terse|noopt|nostrip|nocheck)$/ && 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..df3ec48
--- /dev/null
+++ b/scripts/Dpkg/BuildProfiles.pm
@@ -0,0 +1,146 @@
+# 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/>.
+
+package Dpkg::BuildProfiles;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+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;
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::BuildProfiles - handle build profiles
+
+=head1 DESCRIPTION
+
+The Dpkg::BuildProfiles module provides functions to handle the 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/^(!)?(.+)/;
+
+ 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/BuildTypes.pm b/scripts/Dpkg/BuildTypes.pm
new file mode 100644
index 0000000..9f20d0d
--- /dev/null
+++ b/scripts/Dpkg/BuildTypes.pm
@@ -0,0 +1,284 @@
+# 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/>.
+
+package Dpkg::BuildTypes;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+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;
+
+=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.
+
+=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..ffa7fc2
--- /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 (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;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.00';
+
+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 L<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 L<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 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
+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 and $end < @$data);
+ }
+
+ 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 $f = Dpkg::Control::Changelog->new();
+ $f->{Urgency} = $src->get_urgency() || 'unknown';
+ $f->{Source} = $src->get_source() || 'unknown';
+ $f->{Version} = $src->get_version() // 'unknown';
+ $f->{Distribution} = join(' ', $src->get_distributions());
+ $f->{Maintainer} = $src->get_maintainer() // '';
+ $f->{Date} = $src->get_timestamp() // '';
+ $f->{Timestamp} = $src->get_timepiece && $src->get_timepiece->epoch // '';
+ $f->{Changes} = $src->get_dpkg_changes();
+
+ # handle optional fields
+ my $opts = $src->get_optional_fields();
+ my %closes;
+ foreach (keys %$opts) {
+ if (/^Urgency$/i) { # Already dealt
+ } elsif (/^Closes$/i) {
+ $closes{$_} = 1 foreach (split(/\s+/, $opts->{Closes}));
+ } else {
+ field_transfer_single($opts, $f);
+ }
+ }
+
+ foreach my $bin (@data) {
+ my $oldurg = $f->{Urgency} // '';
+ my $oldurgn = $URGENCIES{$f->{Urgency}} // -1;
+ my $newurg = $bin->get_urgency() // '';
+ my $newurgn = $URGENCIES{$newurg} // -1;
+ $f->{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg;
+ $f->{Changes} .= "\n" . $bin->get_dpkg_changes();
+
+ # handle optional fields
+ $opts = $bin->get_optional_fields();
+ foreach (keys %$opts) {
+ if (/^Closes$/i) {
+ $closes{$_} = 1 foreach (split(/\s+/, $opts->{Closes}));
+ } elsif (not exists $f->{$_}) { # Don't overwrite an existing field
+ field_transfer_single($opts, $f);
+ }
+ }
+ }
+
+ if (scalar keys %closes) {
+ $f->{Closes} = join ' ', sort { $a <=> $b } keys %closes;
+ }
+ run_vendor_hook('post-process-changelog-entry', $f);
+
+ return $f;
+}
+
+sub _format_rfc822 {
+ my ($self, $range) = @_;
+
+ my @data = $self->get_range($range) or return;
+ my @ctrl;
+
+ foreach my $entry (@data) {
+ my $f = Dpkg::Control::Changelog->new();
+ $f->{Urgency} = $entry->get_urgency() || 'unknown';
+ $f->{Source} = $entry->get_source() || 'unknown';
+ $f->{Version} = $entry->get_version() // 'unknown';
+ $f->{Distribution} = join(' ', $entry->get_distributions());
+ $f->{Maintainer} = $entry->get_maintainer() // '';
+ $f->{Date} = $entry->get_timestamp() // '';
+ $f->{Timestamp} = $entry->get_timepiece && $entry->get_timepiece->epoch // '';
+ $f->{Changes} = $entry->get_dpkg_changes();
+
+ # handle optional fields
+ my $opts = $entry->get_optional_fields();
+ foreach (keys %$opts) {
+ field_transfer_single($opts, $f) unless exists $f->{$_};
+ }
+
+ run_vendor_hook('post-process-changelog-entry', $f);
+
+ push @ctrl, $f;
+ }
+
+ return @ctrl;
+}
+
+=item $control = $c->format_range($format, $range)
+
+Formats the changelog into Dpkg::Control::Changelog objects representing the
+entries selected by the optional range specifier (see L<"RANGE SELECTION">
+for details). In scalar context returns a Dpkg::Index object containing the
+selected entries, in list context returns an array of Dpkg::Control::Changelog
+objects.
+
+With format B<dpkg> the returned 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 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 $f (@ctrl) {
+ $index->add($f);
+ }
+
+ 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..44f0be0
--- /dev/null
+++ b/scripts/Dpkg/Changelog/Debian.pm
@@ -0,0 +1,271 @@
+# 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 (Dpkg::Changelog::Entry::Debian).
+It implements the generic interface Dpkg::Changelog.
+Only methods specific to this implementation are described below,
+the rest are inherited.
+
+Dpkg::Changelog::Debian parses Debian changelogs as described in
+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;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+
+use Dpkg::Gettext;
+use Dpkg::File;
+use Dpkg::Changelog qw(:util);
+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 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
+
+Dpkg::Changelog
+
+=cut
diff --git a/scripts/Dpkg/Changelog/Entry.pm b/scripts/Dpkg/Changelog/Entry.pm
new file mode 100644
index 0000000..79b741d
--- /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/>.
+
+package Dpkg::Changelog::Entry;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.01';
+
+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;
+
+=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.
+
+=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 $fields = $entry->get_optional_fields()
+
+Return a set of optional fields exposed by the changelog entry.
+It always returns a 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 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..fee5be8
--- /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/>.
+
+package Dpkg::Changelog::Entry::Debian;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.00';
+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);
+
+=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 Dpkg::Changelog::Entry.
+Only functions specific to this implementation are described below,
+the rest are inherited.
+
+=cut
+
+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 $f = 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;
+ }
+ my ($k, $v) = (field_capitalize($1), $2);
+ if (exists $f->{$k}) {
+ push @errors, sprintf(g_('repeated key-value %s'), $k);
+ } else {
+ $f->{$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} = $f;
+ } 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 $fields = $entry->get_optional_fields()
+
+Return a set of optional fields exposed by the changelog entry.
+It always returns a Dpkg::Control object (possibly empty though).
+
+=cut
+
+sub get_optional_fields {
+ my $self = shift;
+ my $f;
+
+ if (defined $self->{header_fields}) {
+ $f = $self->{header_fields};
+ } else {
+ $f = Dpkg::Control::Changelog->new();
+ }
+
+ my @closes = find_closes(join("\n", @{$self->{changes}}));
+ if (@closes) {
+ $f->{Closes} = join(' ', @closes);
+ }
+
+ return $f;
+}
+
+=item $urgency = $entry->get_urgency()
+
+Return the urgency of the associated upload.
+
+=cut
+
+sub get_urgency {
+ my $self = shift;
+ my $f = $self->get_optional_fields();
+ if (exists $f->{Urgency}) {
+ $f->{Urgency} =~ s/\s.*$//;
+ return lc($f->{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 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..ec9e9ad
--- /dev/null
+++ b/scripts/Dpkg/Changelog/Parse.pm
@@ -0,0 +1,197 @@
+# 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;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.01';
+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
+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
+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{
+ pop \@INC if \$INC[-1] eq '.';
+ 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..4744447
--- /dev/null
+++ b/scripts/Dpkg/Checksums.pm
@@ -0,0 +1,430 @@
+# 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/>.
+
+package Dpkg::Checksums;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.04';
+our @EXPORT = qw(
+ checksums_is_supported
+ checksums_get_list
+ checksums_get_property
+);
+
+use Exporter qw(import);
+use Digest;
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+
+=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.
+
+=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);
+ }
+ 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 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 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 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..189be8b
--- /dev/null
+++ b/scripts/Dpkg/Compression.pm
@@ -0,0 +1,448 @@
+# 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/>.
+
+package Dpkg::Compression;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.01';
+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;
+
+=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
+
+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
+C<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
+C<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 C<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 C<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 C<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 C<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..5b3fd1c
--- /dev/null
+++ b/scripts/Dpkg/Compression/FileHandle.pm
@@ -0,0 +1,473 @@
+# 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/>.
+
+package Dpkg::Compression::FileHandle;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.01';
+
+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
+
+=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 behaviour with the method C<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 C<set_filename> method).
+
+Once a file has been opened, the filehandle must be closed before being
+able to open another file.
+
+=head1 STANDARD FUNCTIONS
+
+The standard functions acting on filehandles should accept a
+Dpkg::Compression::FileHandle object transparently including
+C<open> (only when using the variant with 3 parameters), C<close>,
+C<binmode>, C<eof>, C<fileno>, C<getc>, C<print>, C<printf>, C<read>,
+C<sysread>, C<say>, C<write>, C<syswrite>, C<seek>, C<sysseek>, C<tell>.
+
+Note however that C<seek> and C<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 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) = shift;
+ if (scalar(@_) == 2) {
+ my ($mode, $filename) = @_;
+ $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) = shift;
+ my $ret = 1;
+ if (defined *$self->{file}) {
+ $ret = *$self->{file}->close(@_) if *$self->{file}->opened();
+ } else {
+ $ret = 0;
+ }
+ $self->_cleanup();
+ return $ret;
+}
+
+sub FILENO {
+ my ($self) = shift;
+ return *$self->{file}->fileno(@_) 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) = (shift, shift);
+ return *$self->{file}->eof(@_) if defined *$self->{file};
+ return 1;
+}
+
+sub SEEK {
+ my ($self) = shift;
+ return *$self->{file}->seek(@_) if defined *$self->{file};
+ return 0;
+}
+
+sub TELL {
+ my ($self) = shift;
+ return *$self->{file}->tell(@_) if defined *$self->{file};
+ return -1;
+}
+
+sub BINMODE {
+ my ($self) = shift;
+ return *$self->{file}->binmode(@_) 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
+B<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 C<compression_is_valid_level> of B<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 B<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..3f08d48
--- /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/>.
+
+package Dpkg::Compression::Process;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+
+use Carp;
+
+use Dpkg::Compression;
+use Dpkg::ErrorHandling;
+use Dpkg::Gettext;
+use Dpkg::IPC;
+
+=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.
+
+=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 C<compression_is_supported> (of
+B<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 C<compression_is_valid_level> (of
+B<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 C<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 B<Dpkg::IPC::spawn>.
+
+You must call C<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 B<Dpkg::IPC::spawn>.
+
+You must call C<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 B<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 C<wait_child> function. Most notably you can use the "nocheck" option
+to verify the return code yourself instead of letting C<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..028a293
--- /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/>.
+
+package Dpkg::Conf;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.04';
+
+use Carp;
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+
+use parent qw(Dpkg::Interface::Storable);
+
+use overload
+ '@{}' => sub { return [ $_[0]->get_options() ] },
+ fallback => 1;
+
+=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.
+
+=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..7da5993
--- /dev/null
+++ b/scripts/Dpkg/Control.pm
@@ -0,0 +1,269 @@
+# 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/>.
+
+package Dpkg::Control;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.03';
+our @EXPORT = qw(
+ CTRL_UNKNOWN
+ CTRL_INFO_SRC
+ CTRL_INFO_PKG
+ CTRL_INDEX_SRC
+ CTRL_INDEX_PKG
+ CTRL_REPO_RELEASE
+ CTRL_PKG_SRC
+ CTRL_PKG_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
+);
+
+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);
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Control - parse and manipulate official control-like information
+
+=head1 DESCRIPTION
+
+The Dpkg::Control object is a smart version of 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_INFO_SRC
+
+Corresponds to the first stanza in a F<debian/control> file in
+a Debian source package.
+
+=item CTRL_INFO_PKG
+
+Corresponds to subsequent 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_INDEX_SRC
+
+Corresponds to a stanza in a F<Sources> file of a source package
+repository.
+
+=item CTRL_INDEX_PKG
+
+Corresponds to a stanza in a F<Packages> file of a binary package
+repository.
+
+=item CTRL_PKG_SRC
+
+Corresponds to a .dsc file of a Debian source package.
+
+=item CTRL_PKG_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 package tests control file in F<debian/tests/control>.
+
+=back
+
+=head1 METHODS
+
+All the methods of Dpkg::Control::Hash are available. Those listed below
+are either new or overridden with a different behaviour.
+
+=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_PKG_SRC, CTRL_FILE_CHANGES and
+CTRL_REPO_RELEASE and to 0 otherwise. The option "drop_empty" is set to 0
+for CTRL_INFO_PKG and CTRL_INFO_SRC 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_PKG_SRC | CTRL_FILE_CHANGES | CTRL_REPO_RELEASE)) ? 1 : 0;
+ $$self->{drop_empty} = ($t & (CTRL_INFO_PKG | CTRL_INFO_SRC)) ? 0 : 1;
+ if ($t == CTRL_INFO_SRC) {
+ $$self->{name} = g_('general section of control info file');
+ } elsif ($t == CTRL_INFO_PKG) {
+ $$self->{name} = g_("package's section of control info 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_("package's tests control file");
+ } elsif ($t == CTRL_REPO_RELEASE) {
+ $$self->{name} = sprintf(g_("repository's %s file"), 'Release');
+ } elsif ($t == CTRL_INDEX_SRC) {
+ $$self->{name} = sprintf(g_("stanza in repository's %s file"), 'Sources');
+ } elsif ($t == CTRL_INDEX_PKG) {
+ $$self->{name} = sprintf(g_("stanza in repository's %s file"), 'Packages');
+ } elsif ($t == CTRL_PKG_SRC) {
+ $$self->{name} = sprintf(g_('%s file'), '.dsc');
+ } elsif ($t == CTRL_PKG_DEB) {
+ $$self->{name} = g_('control info of a .deb package');
+ } elsif ($t == CTRL_FILE_BUILDINFO) {
+ $$self->{name} = g_('build information file');
+ } elsif ($t == CTRL_FILE_CHANGES) {
+ $$self->{name} = sprintf(g_('%s file'), '.changes');
+ } 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.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..9184ced
--- /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/>.
+
+package Dpkg::Control::Changelog;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+
+use Dpkg::Control;
+
+use parent qw(Dpkg::Control);
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Control::Changelog - represent info fields output by dpkg-parsechangelog
+
+=head1 DESCRIPTION
+
+This class derives directly from Dpkg::Control with the type
+CTRL_CHANGELOG.
+
+=head1 METHODS
+
+=over 4
+
+=item $c = Dpkg::Control::Changelog->new()
+
+Create a new empty set of changelog related fields.
+
+=cut
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my $self = Dpkg::Control->new(type => CTRL_CHANGELOG, @_);
+ 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..33beeec
--- /dev/null
+++ b/scripts/Dpkg/Control/Fields.pm
@@ -0,0 +1,69 @@
+# 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/>.
+
+package Dpkg::Control::Fields;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+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";
+ }
+}
+
+=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 fieldnames
+with associated meta-data explaining in which type of control information
+they are allowed. The vendor-neutral fieldnames and all functions are
+inherited from Dpkg::Control::FieldsCore.
+
+=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..77216c7
--- /dev/null
+++ b/scripts/Dpkg/Control/FieldsCore.pm
@@ -0,0 +1,1377 @@
+# 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/>.
+
+package Dpkg::Control::FieldsCore;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.01';
+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_INFO_PKG | CTRL_INDEX_PKG | CTRL_PKG_DEB | CTRL_FILE_STATUS,
+ ALL_SRC => CTRL_INFO_SRC | CTRL_INDEX_SRC | CTRL_PKG_SRC,
+ 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_INFO_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_INFO_PKG,
+ separator => FIELD_SEP_SPACE,
+ },
+ 'binary' => {
+ name => 'Binary',
+ allowed => CTRL_PKG_SRC | CTRL_INDEX_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_INFO_SRC | CTRL_FILE_VENDOR) & (~CTRL_INFO_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_INFO_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_PKG_SRC | CTRL_INDEX_SRC | ALL_FILE_MANIFEST,
+ },
+ 'checksums-sha1' => {
+ name => 'Checksums-Sha1',
+ allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | ALL_FILE_MANIFEST,
+ },
+ 'checksums-sha256' => {
+ name => 'Checksums-Sha256',
+ allowed => CTRL_PKG_SRC | CTRL_INDEX_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_INDEX_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_INDEX_PKG,
+ separator => FIELD_SEP_LINE | FIELD_SEP_SPACE,
+ },
+ 'files' => {
+ name => 'Files',
+ allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_CHANGES | CTRL_COPYRIGHT_FILES,
+ separator => FIELD_SEP_LINE | FIELD_SEP_SPACE,
+ },
+ 'format' => {
+ name => 'Format',
+ allowed => CTRL_PKG_SRC | CTRL_INDEX_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_INFO_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_INFO_PKG),
+ },
+ 'maintainer' => {
+ name => 'Maintainer',
+ allowed => CTRL_PKG_DEB | CTRL_INDEX_PKG | CTRL_FILE_STATUS | ALL_SRC | ALL_CHANGES,
+ },
+ 'md5sum' => {
+ # XXX: Wrong capitalization due to historical reasons.
+ name => 'MD5sum',
+ allowed => CTRL_INDEX_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_INDEX_SRC,
+ },
+ 'package-list' => {
+ name => 'Package-List',
+ allowed => ALL_SRC & ~CTRL_INFO_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_INFO_SRC | CTRL_INDEX_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_INFO_SRC,
+ separator => FIELD_SEP_SPACE,
+ },
+ 'section' => {
+ name => 'Section',
+ allowed => CTRL_INFO_SRC | CTRL_INDEX_SRC | ALL_PKG,
+ },
+ 'sha1' => {
+ # XXX: Wrong capitalization due to historical reasons.
+ name => 'SHA1',
+ allowed => CTRL_INDEX_PKG | CTRL_REPO_RELEASE,
+ separator => FIELD_SEP_LINE | FIELD_SEP_SPACE,
+ },
+ 'sha256' => {
+ # XXX: Wrong capitalization due to historical reasons.
+ name => 'SHA256',
+ allowed => CTRL_INDEX_PKG | CTRL_REPO_RELEASE,
+ separator => FIELD_SEP_LINE | FIELD_SEP_SPACE,
+ },
+ 'size' => {
+ name => 'Size',
+ allowed => CTRL_INDEX_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_INDEX_SRC | CTRL_INFO_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_INFO_SRC | CTRL_INFO_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_INFO_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_INFO_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_PKG_SRC() => [
+ 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_PKG_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_INDEX_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_INDEX_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
+ ),
+ ],
+);
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Control::FieldsCore - manage (list of official) control fields
+
+=head1 DESCRIPTION
+
+The modules contains a list of fieldnames with associated meta-data explaining
+in which type of control information they are allowed. The types are the
+CTRL_* constants exported by Dpkg::Control.
+
+=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 Dpkg::Control object to the $to 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_PKG_SRC, CTRL_PKG_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_PKG_SRC), "B"
+(Binary: corresponds to CTRL_PKG_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) = @_;
+ $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_PKG_DEB) or
+ ($dest =~ /S/i and $to_type == CTRL_PKG_SRC) 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_PKG_DEB and
+ $to_type != CTRL_PKG_SRC 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_INDEX_PKG and
+ $ctrl_type != CTRL_PKG_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_PKG_SRC) 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_PKG_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.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..8b7f54f
--- /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/>.
+
+package Dpkg::Control::Hash;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Control::Fields; # Force execution of vendor hook.
+
+use parent qw(Dpkg::Control::HashCore);
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Control::Hash - parse and manipulate a stanza of deb822 fields
+
+=head1 DESCRIPTION
+
+This module is just like Dpkg::Control::HashCore, with vendor-specific
+field knowledge.
+
+=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..0bdb812
--- /dev/null
+++ b/scripts/Dpkg/Control/HashCore.pm
@@ -0,0 +1,589 @@
+# 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/>.
+
+package Dpkg::Control::HashCore;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.02';
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Control::FieldsCore;
+
+# 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]" };
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Control::HashCore - parse and manipulate a stanza of deb822 fields
+
+=head1 DESCRIPTION
+
+The 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
+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.
+
+=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) = (shift, shift, shift);
+
+ $msg = sprintf($msg, @_) if (@_);
+ 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 usa 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 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;
+ }
+}
+
+package Dpkg::Control::HashCore::Tie;
+
+# This class 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 Dpkg::Control.
+
+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.
+
+# 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.
+
+sub new {
+ my $class = shift;
+ my $hash = {};
+ tie %{$hash}, $class, @_; ## 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, $last) = @_;
+ 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 $last;
+ }
+ }
+ return;
+}
+
+1;
+
+=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/Info.pm b/scripts/Dpkg/Control/Info.pm
new file mode 100644
index 0000000..e4bc85e
--- /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/>.
+
+package Dpkg::Control::Info;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.01';
+
+use Dpkg::Control;
+use Dpkg::ErrorHandling;
+use Dpkg::Gettext;
+
+use parent qw(Dpkg::Interface::Storable);
+
+use overload
+ '@{}' => sub { return [ $_[0]->{source}, @{$_[0]->{packages}} ] };
+
+=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>.
+
+=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_INFO_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_INFO_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 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 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 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 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 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..3c8d1c0
--- /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/>.
+
+package Dpkg::Control::Tests;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+
+use Dpkg::Control;
+use Dpkg::Control::Tests::Entry;
+use Dpkg::Index;
+
+use parent qw(Dpkg::Index);
+
+=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>.
+
+=head1 METHODS
+
+All the methods of 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 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..cbcd7e8
--- /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/>.
+
+package Dpkg::Control::Tests::Entry;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Control;
+
+use parent qw(Dpkg::Control);
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Control::Tests::Entry - represents a test suite entry
+
+=head1 DESCRIPTION
+
+This class represents a test suite entry.
+
+=head1 METHODS
+
+All the methods of 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..8dd1aa1
--- /dev/null
+++ b/scripts/Dpkg/Control/Types.pm
@@ -0,0 +1,102 @@
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+package Dpkg::Control::Types;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+our @EXPORT = qw(
+ CTRL_UNKNOWN
+ CTRL_INFO_SRC
+ CTRL_INFO_PKG
+ CTRL_REPO_RELEASE
+ CTRL_INDEX_SRC
+ CTRL_INDEX_PKG
+ CTRL_PKG_SRC
+ CTRL_PKG_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
+);
+
+use Exporter qw(import);
+
+=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 Dpkg::Control which also re-exports the same constants.
+
+This module has been introduced solely to avoid a dependency loop
+between Dpkg::Control and Dpkg::Control::Fields.
+
+=cut
+
+use constant {
+ CTRL_UNKNOWN => 0,
+ # First control stanza in debian/control.
+ CTRL_INFO_SRC => 1 << 0,
+ # Subsequent control stanza in debian/control.
+ CTRL_INFO_PKG => 1 << 1,
+ # Entry in repository's Sources files.
+ CTRL_INDEX_SRC => 1 << 2,
+ # Entry in repository's Packages files.
+ CTRL_INDEX_PKG => 1 << 3,
+ # .dsc file of source package.
+ CTRL_PKG_SRC => 1 << 4,
+ # DEBIAN/control in binary packages.
+ CTRL_PKG_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,
+};
+
+=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..5afa384
--- /dev/null
+++ b/scripts/Dpkg/Deps.pm
@@ -0,0 +1,490 @@
+# 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/>.
+
+package Dpkg::Deps;
+
+=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.
+
+=head1 FUNCTIONS
+
+All the deps_* functions are exported by default.
+
+=over 4
+
+=cut
+
+use strict;
+use warnings;
+use feature qw(current_sub);
+
+our $VERSION = '1.07';
+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;
+
+=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 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 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
+Dpkg::Deps::AND or a Dpkg::Deps::Union. Various options can alter the
+behaviour 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 Dpkg::Deps::Union instead of a 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>.
+
+=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() ];
+ }
+
+ # 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 Dpkg::Deps::Simple dependency
+represents a single dependency statement (it relates to one package only).
+Dpkg::Deps::Multiple dependencies are built on top of this class
+and combine several dependencies in different manners. Dpkg::Deps::AND
+represents the logical "AND" between dependencies while Dpkg::Deps::OR
+represents the logical "OR". Dpkg::Deps::Multiple objects can contain
+Dpkg::Deps::Simple object as well as other 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.
+
+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 Dpkg::Deps::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 Dpkg::Deps::deps_parse().
+
+=head2 Version 1.05 (dpkg 1.17.14)
+
+New function: Dpkg::Deps::deps_iterate().
+
+=head2 Version 1.04 (dpkg 1.17.10)
+
+New options: Add use_profiles, build_profiles, reduce_profiles and
+reduce_restrictions to Dpkg::Deps::deps_parse().
+
+=head2 Version 1.03 (dpkg 1.17.0)
+
+New option: Add build_arch option to Dpkg::Deps::deps_parse().
+
+=head2 Version 1.02 (dpkg 1.17.0)
+
+New function: Dpkg::Deps::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..7b403c2
--- /dev/null
+++ b/scripts/Dpkg/Deps/AND.pm
@@ -0,0 +1,182 @@
+# 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/>.
+
+package Dpkg::Deps::AND;
+
+=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 Dpkg::Deps::Multiple.
+
+=cut
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+
+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 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 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..ef8655f
--- /dev/null
+++ b/scripts/Dpkg/Deps/KnownFacts.pm
@@ -0,0 +1,218 @@
+# 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/>.
+
+package Dpkg::Deps::KnownFacts;
+
+=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
+
+use strict;
+use warnings;
+
+our $VERSION = '2.00';
+
+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 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: Dpkg::Deps::KnownFacts->add_installed_package() now accepts 2
+supplementary parameters ($arch and $multiarch).
+
+Deprecated method: Dpkg::Deps::KnownFacts->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..da12f51
--- /dev/null
+++ b/scripts/Dpkg/Deps/Multiple.pm
@@ -0,0 +1,250 @@
+# 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/>.
+
+package Dpkg::Deps::Multiple;
+
+=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
+
+use strict;
+use warnings;
+
+our $VERSION = '1.02';
+
+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 = shift;
+ my $class = ref($this) || $this;
+ my $self = { list => [ @_ ] };
+
+ 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 = shift;
+
+ push @{$self->{list}}, @_;
+}
+
+=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 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 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) 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..4ce5c98
--- /dev/null
+++ b/scripts/Dpkg/Deps/OR.pm
@@ -0,0 +1,174 @@
+# 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/>.
+
+package Dpkg::Deps::OR;
+
+=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 Dpkg::Deps::Multiple.
+
+=cut
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+
+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 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 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..e6ed550
--- /dev/null
+++ b/scripts/Dpkg/Deps/Simple.pm
@@ -0,0 +1,668 @@
+# 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/>.
+
+package Dpkg::Deps::Simple;
+
+=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
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+use strict;
+use warnings;
+
+our $VERSION = '1.02';
+
+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);
+
+=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.
+
+=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;
+ $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+.-]*/;
+ }
+
+ 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 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 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..148e38e
--- /dev/null
+++ b/scripts/Dpkg/Deps/Union.pm
@@ -0,0 +1,119 @@
+# 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/>.
+
+package Dpkg::Deps::Union;
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Deps::Union - list of unrelated dependencies
+
+=head1 DESCRIPTION
+
+This class represents a list of relationships.
+It inherits from Dpkg::Deps::Multiple.
+
+=cut
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+
+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..ac58b98
--- /dev/null
+++ b/scripts/Dpkg/Dist/Files.pm
@@ -0,0 +1,198 @@
+# 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/>.
+
+package Dpkg::Dist::Files;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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;
+}
+
+1;
diff --git a/scripts/Dpkg/ErrorHandling.pm b/scripts/Dpkg/ErrorHandling.pm
new file mode 100644
index 0000000..81bc00d
--- /dev/null
+++ b/scripts/Dpkg/ErrorHandling.pm
@@ -0,0 +1,263 @@
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+package Dpkg::ErrorHandling;
+
+use strict;
+use warnings;
+use feature qw(state);
+
+our $VERSION = '0.02';
+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) = (shift, shift);
+
+ $msg = sprintf($msg, @_) if (@_);
+
+ my $progname = _progname_prefix();
+ my $typename = _typename_prefix($type);
+
+ return "$progname$typename: $msg\n";
+}
+
+sub debug
+{
+ my $level = shift;
+ print report(REPORT_DEBUG, @_) if $level <= $debug_level;
+}
+
+sub info($;@)
+{
+ print { $info_fh } report(REPORT_INFO, @_) if not $quiet_warnings;
+}
+
+sub notice
+{
+ warn report(REPORT_NOTICE, @_) if not $quiet_warnings;
+}
+
+sub warning($;@)
+{
+ warn report(REPORT_WARN, @_) if not $quiet_warnings;
+}
+
+sub syserr($;@)
+{
+ my $msg = shift;
+ die report(REPORT_ERROR, "$msg: $!", @_);
+}
+
+sub error($;@)
+{
+ die report(REPORT_ERROR, @_);
+}
+
+sub errormsg($;@)
+{
+ print { *STDERR } report(REPORT_ERROR, @_);
+}
+
+sub printcmd
+{
+ my (@cmd) = @_;
+
+ print { *STDERR } report_pretty(" @cmd\n", report_color(REPORT_COMMAND));
+}
+
+sub subprocerr(@)
+{
+ my ($p) = (shift);
+
+ $p = sprintf($p, @_) if (@_);
+
+ 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) = (shift);
+
+ state $printforhelp = g_('Use --help for program usage information.');
+
+ $msg = sprintf($msg, @_) if (@_);
+ warn report(REPORT_ERROR, $msg);
+ warn "\n$printforhelp\n";
+ exit(2);
+}
+
+1;
diff --git a/scripts/Dpkg/Exit.pm b/scripts/Dpkg/Exit.pm
new file mode 100644
index 0000000..460b4ee
--- /dev/null
+++ b/scripts/Dpkg/Exit.pm
@@ -0,0 +1,132 @@
+# 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/>.
+
+package Dpkg::Exit;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.00';
+our @EXPORT_OK = qw(
+ push_exit_handler
+ pop_exit_handler
+ run_exit_handlers
+);
+
+use Exporter qw(import);
+
+my @handlers = ();
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Exit - program exit handlers
+
+=head1 DESCRIPTION
+
+The Dpkg::Exit module provides support functions to run handlers on exit.
+
+=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..dd3fd9f
--- /dev/null
+++ b/scripts/Dpkg/File.pm
@@ -0,0 +1,79 @@
+# 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/>.
+
+package Dpkg::File;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+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);
+}
+
+1;
diff --git a/scripts/Dpkg/Getopt.pm b/scripts/Dpkg/Getopt.pm
new file mode 100644
index 0000000..bebe9f8
--- /dev/null
+++ b/scripts/Dpkg/Getopt.pm
@@ -0,0 +1,48 @@
+# 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/>.
+
+package Dpkg::Getopt;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+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;
+}
+
+1;
diff --git a/scripts/Dpkg/Gettext.pm b/scripts/Dpkg/Gettext.pm
new file mode 100644
index 0000000..bac8f57
--- /dev/null
+++ b/scripts/Dpkg/Gettext.pm
@@ -0,0 +1,235 @@
+# Copied from /usr/share/perl5/Debconf/Gettext.pm
+#
+# Copyright © 2000 Joey Hess <joeyh@debian.org>
+# Copyright © 2007-2022 Guillem Jover <guillem@debian.org>
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+
+package Dpkg::Gettext;
+
+use strict;
+use warnings;
+use feature qw(state);
+
+our $VERSION = '2.01';
+our @EXPORT = qw(
+ textdomain
+ gettext
+ ngettext
+ g_
+ P_
+ N_
+);
+
+use Exporter qw(import);
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Gettext - convenience wrapper around Locale::gettext
+
+=head1 DESCRIPTION
+
+The Dpkg::Gettext module is a convenience wrapper over the Locale::gettext
+module, to guarantee we always have working gettext functions, and to add
+some commonly used aliases.
+
+=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 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 Locale::gettext is not available.
+
+Returns $msgid.
+
+=item $trans = ngettext($msgid, $msgid_plural, $n)
+
+Compatibility ngettext() fallback when 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{
+ pop @INC if $INC[-1] eq '.';
+ 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..2503642
--- /dev/null
+++ b/scripts/Dpkg/IPC.pm
@@ -0,0 +1,420 @@
+# 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/>.
+
+package Dpkg::IPC;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.02';
+our @EXPORT = qw(
+ spawn
+ wait_child
+);
+
+use Carp;
+use Exporter qw(import);
+
+use Dpkg::ErrorHandling;
+use Dpkg::Gettext;
+
+=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.
+
+=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
+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 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
+
+Dpkg, Dpkg::ErrorHandling
diff --git a/scripts/Dpkg/Index.pm b/scripts/Dpkg/Index.pm
new file mode 100644
index 0000000..46027d0
--- /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/>.
+
+package Dpkg::Index;
+
+use strict;
+use warnings;
+
+our $VERSION = '3.00';
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Control;
+
+use parent qw(Dpkg::Interface::Storable);
+
+use overload
+ '@{}' => sub { return $_[0]->{order} },
+ fallback => 1;
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Index - generic index of control information
+
+=head1 DESCRIPTION
+
+This class represent a set of Dpkg::Control objects.
+
+=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_INFO_SRC, it is the Source field;
+
+=item *
+
+for CTRL_INDEX_SRC and CTRL_PKG_SRC 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_INFO_PKG it is simply the Package field;
+
+=item *
+
+for CTRL_INDEX_PKG and CTRL_PKG_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_INFO_PKG) {
+ $self->{get_key_func} = sub { return $_[0]->{Package}; };
+ } elsif ($t == CTRL_INFO_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_INDEX_SRC or $t == CTRL_PKG_SRC) {
+ 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_INDEX_PKG or $t == CTRL_PKG_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 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..5ac078a
--- /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/>.
+
+package Dpkg::Interface::Storable;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.01';
+
+use Carp;
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+
+use overload
+ '""' => \&_stringify,
+ 'fallback' => 1;
+
+=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().
+
+=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
+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
+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..6344779
--- /dev/null
+++ b/scripts/Dpkg/Lock.pm
@@ -0,0 +1,61 @@
+# 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/>.
+
+package Dpkg::Lock;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+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{
+ pop @INC if $INC[-1] eq '.';
+ 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);
+ }
+ }
+}
+
+1;
diff --git a/scripts/Dpkg/OpenPGP.pm b/scripts/Dpkg/OpenPGP.pm
new file mode 100644
index 0000000..2e12ea7
--- /dev/null
+++ b/scripts/Dpkg/OpenPGP.pm
@@ -0,0 +1,155 @@
+# 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/>.
+
+package Dpkg::OpenPGP;
+
+use strict;
+use warnings;
+
+use List::Util qw(none);
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::IPC;
+use Dpkg::Path qw(find_command);
+
+our $VERSION = '0.01';
+
+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{
+ pop \@INC if \$INC[-1] eq '.';
+ 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);
+}
+
+1;
diff --git a/scripts/Dpkg/OpenPGP/Backend.pm b/scripts/Dpkg/OpenPGP/Backend.pm
new file mode 100644
index 0000000..48cfd22
--- /dev/null
+++ b/scripts/Dpkg/OpenPGP/Backend.pm
@@ -0,0 +1,127 @@
+# 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/>.
+
+package Dpkg::OpenPGP::Backend;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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 = {
+ strict_verify => $opts{strict_verify} // 1,
+ };
+ 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;
+}
+
+1;
diff --git a/scripts/Dpkg/OpenPGP/Backend/GnuPG.pm b/scripts/Dpkg/OpenPGP/Backend/GnuPG.pm
new file mode 100644
index 0000000..7cc7bc7
--- /dev/null
+++ b/scripts/Dpkg/OpenPGP/Backend/GnuPG.pm
@@ -0,0 +1,301 @@
+# Copyright © 207, 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/>.
+
+package Dpkg::OpenPGP::Backend::GnuPG;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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 @keyrings;
+ if (length $ENV{HOME} and -r "$ENV{HOME}/.gnupg/trustedkeys.gpg") {
+ push @keyrings, "$ENV{HOME}/.gnupg/trustedkeys.gpg";
+ }
+ 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 (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_KEY_CANNOT_SIGN if $rc;
+ return OPENPGP_OK;
+}
+
+1;
diff --git a/scripts/Dpkg/OpenPGP/Backend/SOP.pm b/scripts/Dpkg/OpenPGP/Backend/SOP.pm
new file mode 100644
index 0000000..1c5073b
--- /dev/null
+++ b/scripts/Dpkg/OpenPGP/Backend/SOP.pm
@@ -0,0 +1,108 @@
+# 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/>.
+
+package Dpkg::OpenPGP::Backend::SOP;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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 "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);
+}
+
+1;
diff --git a/scripts/Dpkg/OpenPGP/Backend/Sequoia.pm b/scripts/Dpkg/OpenPGP/Backend/Sequoia.pm
new file mode 100644
index 0000000..5313393
--- /dev/null
+++ b/scripts/Dpkg/OpenPGP/Backend/Sequoia.pm
@@ -0,0 +1,123 @@
+# 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/>.
+
+package Dpkg::OpenPGP::Backend::Sequoia;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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-cert', $_) } @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-cert', $_) } @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-key', $key->handle;
+ push @opts, '--output', $inlinesigned;
+
+ my $rc = $self->_sq_exec('sign', @opts, $data);
+ return OPENPGP_KEY_CANNOT_SIGN if $rc;
+ return OPENPGP_OK;
+}
+
+1;
diff --git a/scripts/Dpkg/OpenPGP/ErrorCodes.pm b/scripts/Dpkg/OpenPGP/ErrorCodes.pm
new file mode 100644
index 0000000..67bd39b
--- /dev/null
+++ b/scripts/Dpkg/OpenPGP/ErrorCodes.pm
@@ -0,0 +1,93 @@
+# 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/>.
+
+package Dpkg::OpenPGP::ErrorCodes;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+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_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,
+};
+
+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'),
+);
+
+sub openpgp_errorcode_to_string
+{
+ my $code = shift;
+
+ return gettext($code2error{$code}) if exists $code2error{$code};
+ return sprintf g_('error code %d'), $code;
+}
+
+1;
diff --git a/scripts/Dpkg/OpenPGP/KeyHandle.pm b/scripts/Dpkg/OpenPGP/KeyHandle.pm
new file mode 100644
index 0000000..89ae448
--- /dev/null
+++ b/scripts/Dpkg/OpenPGP/KeyHandle.pm
@@ -0,0 +1,103 @@
+# 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/>.
+
+package Dpkg::OpenPGP::KeyHandle;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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};
+}
+
+1;
diff --git a/scripts/Dpkg/Package.pm b/scripts/Dpkg/Package.pm
new file mode 100644
index 0000000..e49c01b
--- /dev/null
+++ b/scripts/Dpkg/Package.pm
@@ -0,0 +1,47 @@
+# Copyright © 2006 Frank Lichtenheld <djpig@debian.org>
+# Copyright © 2007,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/>.
+
+package Dpkg::Package;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+our @EXPORT = qw(
+ pkg_name_is_illegal
+);
+
+use Exporter qw(import);
+
+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;
+}
+
+1;
diff --git a/scripts/Dpkg/Path.pm b/scripts/Dpkg/Path.pm
new file mode 100644
index 0000000..e9dff5c
--- /dev/null
+++ b/scripts/Dpkg/Path.pm
@@ -0,0 +1,354 @@
+# 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/>.
+
+package Dpkg::Path;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.05';
+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;
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Path - some common path handling functions
+
+=head1 DESCRIPTION
+
+It provides some functions to handle various path.
+
+=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 $f ("$base.$host_arch", "$base.$host_os", "$base") {
+ push @files, $f if -f $f;
+ }
+ 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..22fecc4
--- /dev/null
+++ b/scripts/Dpkg/Shlibs.pm
@@ -0,0 +1,184 @@
+# 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/>.
+
+package Dpkg::Shlibs;
+
+use strict;
+use warnings;
+use feature qw(state);
+
+our $VERSION = '0.03';
+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::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/) {
+ warning(g_('deprecated use of LD_LIBRARY_PATH with private ' .
+ 'library directory which interferes with ' .
+ 'cross-building, please use -l option instead'));
+ }
+
+ # 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=0x%s != objabi=0x%s",
+ unpack('H*', $libformat), unpack('H*', $format));
+ }
+ }
+ }
+ return @libs;
+}
+
+1;
diff --git a/scripts/Dpkg/Shlibs/Cppfilt.pm b/scripts/Dpkg/Shlibs/Cppfilt.pm
new file mode 100644
index 0000000..c2a4756
--- /dev/null
+++ b/scripts/Dpkg/Shlibs/Cppfilt.pm
@@ -0,0 +1,120 @@
+# 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/>.
+
+package Dpkg::Shlibs::Cppfilt;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+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;
+}
+
+1;
diff --git a/scripts/Dpkg/Shlibs/Objdump.pm b/scripts/Dpkg/Shlibs/Objdump.pm
new file mode 100644
index 0000000..c9af965
--- /dev/null
+++ b/scripts/Dpkg/Shlibs/Objdump.pm
@@ -0,0 +1,582 @@
+# 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/>.
+
+package Dpkg::Shlibs::Objdump;
+
+use strict;
+use warnings;
+use feature qw(state);
+
+our $VERSION = '0.01';
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+
+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_SPARC => 2,
+ EM_MIPS => 8,
+ EM_SPARC64_OLD => 11,
+ EM_SPARC32PLUS => 18,
+ EM_PPC64 => 21,
+ EM_S390 => 22,
+ EM_ARM => 40,
+ EM_ALPHA_OLD => 41,
+ EM_SH => 42,
+ EM_SPARC64 => 43,
+ EM_IA64 => 50,
+ EM_AVR => 83,
+ EM_M32R => 88,
+ EM_MN10300 => 89,
+ EM_MN10200 => 90,
+ EM_OR1K => 92,
+ EM_XTENSA => 94,
+ EM_MICROBLAZE => 189,
+ EM_ARCV2 => 195,
+ EM_LOONGARCH => 258,
+ EM_AVR_OLD => 0x1057,
+ EM_OR1K_OLD => 0x8472,
+ EM_ALPHA => 0x9026,
+ EM_M32R_CYGNUS => 0x9041,
+ EM_S390_OLD => 0xa390,
+ EM_XTENSA_OLD => 0xabc7,
+ EM_MICROBLAZE_OLD => 0xbaab,
+ EM_MN10300_CYGNUS => 0xbeef,
+ EM_MN10200_CYGNUS => 0xdead,
+
+ # 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_PPC64_ABI64 => 0x00000003,
+
+ EF_SH_MACH_MASK => 0x0000001f,
+};
+
+# These map alternative or old machine IDs to their canonical form.
+my %elf_mach_map = (
+ EM_ALPHA_OLD() => EM_ALPHA,
+ EM_AVR_OLD() => EM_AVR,
+ EM_M32R_CYGNUS() => EM_M32R,
+ EM_MICROBLAZE_OLD() => EM_MICROBLAZE,
+ EM_MN10200_CYGNUS() => EM_MN10200,
+ EM_MN10300_CYGNUS() => EM_MN10300,
+ EM_OR1K_OLD() => EM_OR1K,
+ EM_S390_OLD() => EM_S390,
+ EM_SPARC32PLUS() => EM_SPARC,
+ EM_SPARC64_OLD() => EM_SPARC64,
+ EM_XTENSA_OLD() => EM_XTENSA,
+);
+
+# 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 = (
+ EM_IA64() => EF_IA64_ABI64,
+ EM_LOONGARCH() => EF_LOONGARCH_ABI_MASK,
+ EM_MIPS() => EF_MIPS_ABI_MASK | EF_MIPS_ABI2,
+ EM_PPC64() => EF_PPC64_ABI64,
+);
+
+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 ($elf_word, $elf_endian);
+ if ($elf{bits} == ELF_BITS_32) {
+ $elf_word = 'L';
+ } elsif ($elf{bits} == ELF_BITS_64) {
+ $elf_word = 'Q';
+ } else {
+ return;
+ }
+ if ($elf{endian} == ELF_ORDER_2LSB) {
+ $elf_endian = '<';
+ } elsif ($elf{endian} == ELF_ORDER_2MSB) {
+ $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};
+
+ # Mask any processor flags that might not change the architecture ABI.
+ $elf{flags} &= $elf_flags_mask{$elf{mach}} // 0;
+
+ # Repack for easy comparison, as a big-endian byte stream, so that
+ # unpacking for output gives meaningful results.
+ $format{$file} = pack 'C2(SL)>', @elf{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;
+}
+
+package Dpkg::Shlibs::Objdump::Object;
+
+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};
+}
+
+1;
diff --git a/scripts/Dpkg/Shlibs/Symbol.pm b/scripts/Dpkg/Shlibs/Symbol.pm
new file mode 100644
index 0000000..e6460ce
--- /dev/null
+++ b/scripts/Dpkg/Shlibs/Symbol.pm
@@ -0,0 +1,531 @@
+# 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/>.
+
+package Dpkg::Shlibs::Symbol;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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
+);
+
+# Needed by the deprecated key, which is a correct use.
+no if $Dpkg::Version::VERSION ge '1.02',
+ warnings => qw(Dpkg::Version::semantic_change::overload::bool);
+
+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
+ my $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;
+}
+
+1;
diff --git a/scripts/Dpkg/Shlibs/SymbolFile.pm b/scripts/Dpkg/Shlibs/SymbolFile.pm
new file mode 100644
index 0000000..d492055
--- /dev/null
+++ b/scripts/Dpkg/Shlibs/SymbolFile.pm
@@ -0,0 +1,697 @@
+# 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/>.
+
+package Dpkg::Shlibs::SymbolFile;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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);
+
+# Needed by the deprecated key, which is a correct use.
+no if $Dpkg::Version::VERSION ge '1.02',
+ warnings => qw(Dpkg::Version::semantic_change::overload::bool);
+
+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);
+}
+
+1;
diff --git a/scripts/Dpkg/Source/Archive.pm b/scripts/Dpkg/Source/Archive.pm
new file mode 100644
index 0000000..88e6700
--- /dev/null
+++ b/scripts/Dpkg/Source/Archive.pm
@@ -0,0 +1,240 @@
+# 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/>.
+
+package Dpkg::Source::Archive;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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};
+ $file = $2 if ($file =~ /^\Q$cwd\E\/(.+)$/); # Relative names
+ 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 => 'tar -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);
+}
+
+1;
diff --git a/scripts/Dpkg/Source/BinaryFiles.pm b/scripts/Dpkg/Source/BinaryFiles.pm
new file mode 100644
index 0000000..48c84c8
--- /dev/null
+++ b/scripts/Dpkg/Source/BinaryFiles.pm
@@ -0,0 +1,161 @@
+# 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/>.
+
+package Dpkg::Source::BinaryFiles;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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;
+}
+
+1;
diff --git a/scripts/Dpkg/Source/Format.pm b/scripts/Dpkg/Source/Format.pm
new file mode 100644
index 0000000..41596a2
--- /dev/null
+++ b/scripts/Dpkg/Source/Format.pm
@@ -0,0 +1,191 @@
+# 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/>.
+
+package Dpkg::Source::Format;
+
+=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
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+
+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..0576657
--- /dev/null
+++ b/scripts/Dpkg/Source/Functions.pm
@@ -0,0 +1,124 @@
+# 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/>.
+
+package Dpkg::Source::Functions;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+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;
+}
+
+1;
diff --git a/scripts/Dpkg/Source/Package.pm b/scripts/Dpkg/Source/Package.pm
new file mode 100644
index 0000000..412ea5d
--- /dev/null
+++ b/scripts/Dpkg/Source/Package.pm
@@ -0,0 +1,741 @@
+# 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/>.
+
+package Dpkg::Source::Package;
+
+=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
+
+use strict;
+use warnings;
+
+our $VERSION = '2.02';
+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_PKG_SRC),
+ 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{
+ pop \@INC if \$INC[-1] eq '.';
+ 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 = shift;
+
+ $self->do_build(@_);
+}
+
+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 = shift;
+
+ $self->do_commit(@_);
+}
+
+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..96e2932
--- /dev/null
+++ b/scripts/Dpkg/Source/Package/V1.pm
@@ -0,0 +1,512 @@
+# 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/>.
+
+package Dpkg::Source::Package::V1;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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);
+ }
+}
+
+1;
diff --git a/scripts/Dpkg/Source/Package/V2.pm b/scripts/Dpkg/Source/Package/V2.pm
new file mode 100644
index 0000000..b3c21e5
--- /dev/null
+++ b/scripts/Dpkg/Source/Package/V2.pm
@@ -0,0 +1,744 @@
+# 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/>.
+
+package Dpkg::Source::Package::V2;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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';
+This is an 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.
+
+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);
+}
+
+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..2f18fee
--- /dev/null
+++ b/scripts/Dpkg/Source/Package/V3/Bzr.pm
@@ -0,0 +1,213 @@
+#
+# bzr support for dpkg-source
+#
+# 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/>.
+
+package Dpkg::Source::Package::V3::Bzr;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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);
+}
+
+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..63f1769
--- /dev/null
+++ b/scripts/Dpkg/Source/Package/V3/Custom.pm
@@ -0,0 +1,74 @@
+# 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/>.
+
+package Dpkg::Source::Package::V3::Custom;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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);
+ }
+}
+
+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..721036a
--- /dev/null
+++ b/scripts/Dpkg/Source/Package/V3/Git.pm
@@ -0,0 +1,283 @@
+#
+# git support for dpkg-source
+#
+# 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/>.
+
+package Dpkg::Source::Package::V3::Git;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+
+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 $?;
+ }
+}
+
+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..933315a
--- /dev/null
+++ b/scripts/Dpkg/Source/Package/V3/Native.pm
@@ -0,0 +1,121 @@
+# 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/>.
+
+package Dpkg::Source::Package::V3::Native;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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);
+}
+
+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..1359168
--- /dev/null
+++ b/scripts/Dpkg/Source/Package/V3/Quilt.pm
@@ -0,0 +1,269 @@
+# 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/>.
+
+package Dpkg::Source::Package::V3::Quilt;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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;
+}
+
+1;
diff --git a/scripts/Dpkg/Source/Patch.pm b/scripts/Dpkg/Source/Patch.pm
new file mode 100644
index 0000000..e670898
--- /dev/null
+++ b/scripts/Dpkg/Source/Patch.pm
@@ -0,0 +1,697 @@
+# 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/>.
+
+package Dpkg::Source::Patch;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+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 ':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', LANG => '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 and not -f _) {
+ error(g_("diff '%s' patches something which is not a plain file"),
+ $diff);
+ }
+
+ 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', LANG => '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', LANG => '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');
+ }
+}
+
+1;
diff --git a/scripts/Dpkg/Source/Quilt.pm b/scripts/Dpkg/Source/Quilt.pm
new file mode 100644
index 0000000..3e655fa
--- /dev/null
+++ b/scripts/Dpkg/Source/Quilt.pm
@@ -0,0 +1,383 @@
+# 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/>.
+
+package Dpkg::Source::Quilt;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+
+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_file();
+ 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_file();
+ 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 = shift;
+ return File::Spec->catfile($self->{dir}, '.pc', @_);
+}
+
+sub get_db_dir {
+ my $self = shift;
+ return $self->get_db_file();
+}
+
+sub get_patch_file {
+ my $self = shift;
+ return File::Spec->catfile($self->{dir}, 'debian', 'patches', @_);
+}
+
+sub get_patch_dir {
+ my $self = shift;
+ return $self->get_patch_file();
+}
+
+## 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);
+}
+
+1;
diff --git a/scripts/Dpkg/Substvars.pm b/scripts/Dpkg/Substvars.pm
new file mode 100644
index 0000000..d2abc3f
--- /dev/null
+++ b/scripts/Dpkg/Substvars.pm
@@ -0,0 +1,501 @@
+# 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/>.
+
+package Dpkg::Substvars;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.01';
+
+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;
+
+=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
+
+use constant {
+ SUBSTVAR_ATTR_USED => 1,
+ SUBSTVAR_ATTR_AUTO => 2,
+ SUBSTVAR_ATTR_AGED => 4,
+ SUBSTVAR_ATTR_OPT => 8,
+};
+
+=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;
+
+ $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, $.);
+ }
+ 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 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 $lhs;
+ my $vn;
+ my $rhs = '';
+ my $count = 0;
+ $opts{msg_prefix} //= $self->{msg_prefix};
+ $opts{no_warn} //= 0;
+
+ while ($v =~ m/^(.*?)\$\{([-:0-9a-z]+)\}(.*)$/si) {
+ # If we have consumed more from the leftover data, then
+ # reset the recursive counter.
+ $count = 0 if (length($3) < length($rhs));
+
+ if ($count >= $maxsubsts) {
+ error($opts{msg_prefix} .
+ g_("too many substitutions - recursive ? - in '%s'"), $v);
+ }
+ $lhs = $1;
+ $vn = $2;
+ $rhs = $3;
+ if (defined($self->{vars}{$vn})) {
+ $v = $lhs . $self->{vars}{$vn} . $rhs;
+ $self->mark_as_used($vn);
+ $count++;
+
+ 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/Vars.pm b/scripts/Dpkg/Vars.pm
new file mode 100644
index 0000000..2253e39
--- /dev/null
+++ b/scripts/Dpkg/Vars.pm
@@ -0,0 +1,53 @@
+# 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/>.
+
+package Dpkg::Vars;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.03';
+our @EXPORT = qw(
+ get_source_package
+ set_source_package
+);
+
+use Exporter qw(import);
+
+use Dpkg::ErrorHandling;
+use Dpkg::Gettext;
+use Dpkg::Package;
+
+my $sourcepackage;
+
+sub get_source_package {
+ return $sourcepackage;
+}
+
+sub set_source_package {
+ my $v = shift;
+ my $err = pkg_name_is_illegal($v);
+ error(g_("source package name '%s' is illegal: %s"), $v, $err) if $err;
+
+ if (not defined($sourcepackage)) {
+ $sourcepackage = $v;
+ } elsif ($v ne $sourcepackage) {
+ error(g_('source package has two conflicting values - %s and %s'),
+ $sourcepackage, $v);
+ }
+}
+
+1;
diff --git a/scripts/Dpkg/Vendor.pm b/scripts/Dpkg/Vendor.pm
new file mode 100644
index 0000000..059e442
--- /dev/null
+++ b/scripts/Dpkg/Vendor.pm
@@ -0,0 +1,289 @@
+# 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/>.
+
+package Dpkg::Vendor;
+
+use strict;
+use warnings;
+use feature qw(state);
+
+our $VERSION = '1.02';
+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};
+
+=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.
+
+=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 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 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{
+ pop \@INC if \$INC[-1] eq '.';
+ 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 $vendor_obj = get_vendor_object();
+ $vendor_obj->run_hook(@_);
+}
+
+=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
+
+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..06aa49a
--- /dev/null
+++ b/scripts/Dpkg/Vendor/Debian.pm
@@ -0,0 +1,522 @@
+# 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/>.
+
+package Dpkg::Vendor::Debian;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use Dpkg;
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Control::Types;
+
+use parent qw(Dpkg::Vendor::Default);
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Vendor::Debian - Debian vendor class
+
+=head1 DESCRIPTION
+
+This vendor class customizes the behaviour of dpkg scripts for Debian
+specific behavior and policies.
+
+=cut
+
+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 => {
+ lfs => 0,
+ },
+ qa => {
+ bug => 0,
+ 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,
+ fortify => 1,
+ format => 1,
+ relro => 1,
+ bindnow => 0,
+ },
+ );
+
+ my %builtin_feature = (
+ hardening => {
+ pie => 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});
+ }
+
+ require Dpkg::Arch;
+
+ my $arch = Dpkg::Arch::get_host_arch();
+ my ($abi, $libc, $os, $cpu) = Dpkg::Arch::debarch_to_debtuple($arch);
+
+ unless (defined $abi and defined $libc and defined $os and defined $cpu) {
+ warning(g_("unknown host architecture '%s'"), $arch);
+ ($abi, $os, $cpu) = ('', '', '');
+ }
+
+ ## Area: future
+
+ if ($use_feature{future}{lfs}) {
+ my ($abi_bits, $abi_endian) = Dpkg::Arch::debarch_to_abiattrs($arch);
+ my $cpu_bits = Dpkg::Arch::debarch_to_cpubits($arch);
+
+ if ($abi_bits != 32 or $cpu_bits != 32) {
+ $use_feature{future}{lfs} = 0;
+ }
+ }
+
+ ## 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 builtin features that are not enabled by default in the compiler.
+ my %builtin_pie_arch = map { $_ => 1 } qw(
+ amd64
+ arm64
+ armel
+ armhf
+ hurd-i386
+ i386
+ kfreebsd-amd64
+ kfreebsd-i386
+ mips
+ mipsel
+ mips64el
+ powerpc
+ ppc64
+ ppc64el
+ riscv64
+ s390x
+ sparc
+ sparc64
+ );
+ if (not exists $builtin_pie_arch{$arch}) {
+ $builtin_feature{hardening}{pie} = 0;
+ }
+
+ # Mask features that are not available on certain architectures.
+ if ($os !~ /^(?:linux|kfreebsd|knetbsd|hurd)$/ or
+ $cpu =~ /^(?:hppa|avr32)$/) {
+ # Disabled on non-(linux/kfreebsd/knetbsd/hurd).
+ # Disabled on hppa, avr32
+ # (#574716).
+ $use_feature{hardening}{pie} = 0;
+ }
+ if ($cpu =~ /^(?: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 ($cpu =~ /^(?:ia64|hppa|avr32)$/) {
+ # relro not implemented on ia64, hppa, avr32.
+ $use_feature{hardening}{relro} = 0;
+ }
+
+ # 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;
+ }
+
+ # 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
+ GCJFLAGS
+ );
+
+ 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('DFLAGS', $default_d_flags);
+
+ ## Area: future
+
+ if ($flags->use_feature('future', 'lfs')) {
+ $flags->append('CPPFLAGS',
+ '-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64');
+ }
+
+ ## Area: qa
+
+ # Warnings that detect actual bugs.
+ if ($flags->use_feature('qa', 'bug')) {
+ # C flags
+ my @cflags = qw(
+ implicit-function-declaration
+ );
+ foreach my $warnflag (@cflags) {
+ $flags->append('CFLAGS', "-Werror=$warnflag");
+ }
+
+ # 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;
+ }
+
+ # Fortify Source
+ if ($flags->use_feature('hardening', 'fortify')) {
+ $flags->append('CPPFLAGS', '-D_FORTIFY_SOURCE=2');
+ }
+
+ # 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');
+ }
+}
+
+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..8362b5b
--- /dev/null
+++ b/scripts/Dpkg/Vendor/Default.pm
@@ -0,0 +1,229 @@
+# 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/>.
+
+package Dpkg::Vendor::Default;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+# If you use this file as template to create a new vendor class, please
+# uncomment the following lines
+#use parent qw(Dpkg::Vendor::Default);
+
+=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 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.
+
+=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 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 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 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 Dpkg::Changelog to post-process a
+Dpkg::Changelog::Entry after it has been created and filled with the
+appropriate values.
+
+=item update-buildflags ($flags)
+
+The hook is called in Dpkg::BuildFlags to allow the vendor to override
+the default values set for the various build flags. $flags is a
+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..661dc9e
--- /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/>.
+
+package Dpkg::Vendor::Devuan;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use parent qw(Dpkg::Vendor::Debian);
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Vendor::Devuan - Devuan vendor class
+
+=head1 DESCRIPTION
+
+This vendor class customizes the behaviour of dpkg scripts for Devuan
+specific behavior and policies.
+
+=cut
+
+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..9c77519
--- /dev/null
+++ b/scripts/Dpkg/Vendor/Ubuntu.pm
@@ -0,0 +1,174 @@
+# 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/>.
+
+package Dpkg::Vendor::Ubuntu;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use List::Util qw(any);
+
+use Dpkg::ErrorHandling;
+use Dpkg::Gettext;
+use Dpkg::Control::Types;
+
+use parent qw(Dpkg::Vendor::Debian);
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Vendor::Ubuntu - Ubuntu vendor class
+
+=head1 DESCRIPTION
+
+This vendor class customizes the behaviour of dpkg scripts for Ubuntu
+specific behavior and policies.
+
+=cut
+
+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);
+ }
+}
+
+=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..51d46c5
--- /dev/null
+++ b/scripts/Dpkg/Version.pm
@@ -0,0 +1,491 @@
+# 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/>.
+
+package Dpkg::Version;
+
+use strict;
+use warnings;
+use warnings::register qw(semantic_change::overload::bool);
+
+our $VERSION = '1.03';
+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;
+
+=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.
+
+=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 will emit a warning with
+category "Dpkg::Version::semantic_change::overload::bool" until dpkg 1.20.x.
+Once fixed, or for already valid code the warning can be quiesced with
+
+ no if $Dpkg::Version::VERSION ge '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;