diff options
Diffstat (limited to 'scripts/Dpkg/Source/Package/V3')
| -rw-r--r-- | scripts/Dpkg/Source/Package/V3/Bzr.pm | 213 | ||||
| -rw-r--r-- | scripts/Dpkg/Source/Package/V3/Custom.pm | 74 | ||||
| -rw-r--r-- | scripts/Dpkg/Source/Package/V3/Git.pm | 283 | ||||
| -rw-r--r-- | scripts/Dpkg/Source/Package/V3/Native.pm | 121 | ||||
| -rw-r--r-- | scripts/Dpkg/Source/Package/V3/Quilt.pm | 269 |
5 files changed, 960 insertions, 0 deletions
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; |