summaryrefslogtreecommitdiffstats
path: root/scripts/Dpkg/Source
diff options
context:
space:
mode:
Diffstat (limited to 'scripts/Dpkg/Source')
-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
14 files changed, 4753 insertions, 0 deletions
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;
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 14:36:25 +0000