Index: third_party/dpkg-dev/scripts/Dpkg/Source/Package.pm |
diff --git a/third_party/dpkg-dev/scripts/Dpkg/Source/Package.pm b/third_party/dpkg-dev/scripts/Dpkg/Source/Package.pm |
new file mode 100644 |
index 0000000000000000000000000000000000000000..ce07a79cc5cd11d6df8474b152f6a39036d00c1b |
--- /dev/null |
+++ b/third_party/dpkg-dev/scripts/Dpkg/Source/Package.pm |
@@ -0,0 +1,631 @@ |
+# Copyright © 2008-2011 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; |
+ |
+=encoding utf8 |
+ |
+=head1 NAME |
+ |
+Dpkg::Source::Package - manipulate Debian source packages |
+ |
+=head1 DESCRIPTION |
+ |
+This module provides an object 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. |
+ |
+=head1 FUNCTIONS |
+ |
+=cut |
+ |
+use strict; |
+use warnings; |
+ |
+our $VERSION = '1.01'; |
+ |
+use Dpkg::Gettext; |
+use Dpkg::ErrorHandling; |
+use Dpkg::Control; |
+use Dpkg::Checksums; |
+use Dpkg::Version; |
+use Dpkg::Compression; |
+use Dpkg::Exit qw(run_exit_handlers); |
+use Dpkg::Path qw(check_files_are_the_same find_command); |
+use Dpkg::IPC; |
+use Dpkg::Vendor qw(run_vendor_hook); |
+ |
+use Carp; |
+use POSIX qw(:errno_h :sys_wait_h); |
+use File::Basename; |
+ |
+use Exporter qw(import); |
+our @EXPORT_OK = qw(get_default_diff_ignore_regex |
+ set_default_diff_ignore_regex |
+ get_default_tar_ignore_pattern); |
+ |
+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)ignore)$| |
+# File or directory names that should be ignored |
+(?:^|/)(?:CVS|RCS|\.deps|\{arch\}|\.arch-ids|\.svn| |
+\.hg(?:tags|sigs)?|_darcs|\.git(?:attributes|modules)?| |
+\.shelf|_MTN|\.be|\.bzr(?:\.backup|tags)?)(?:$|/.*$) |
+'; |
+# Take out comments and newlines |
+$diff_ignore_default_regex =~ s/^#.*$//mg; |
+$diff_ignore_default_regex =~ s/\n//sg; |
+ |
+# Public variables |
+# XXX: Backwards compatibility, stop exporting on VERSION 2.00. |
+## no critic (Variables::ProhibitPackageVars) |
+our $diff_ignore_default_regexp; |
+*diff_ignore_default_regexp = \$diff_ignore_default_regex; |
+ |
+no warnings 'qw'; ## no critic (TestingAndDebugging::ProhibitNoWarnings) |
+our @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 |
+.hg |
+.hgignore |
+.hgsigs |
+.hgtags |
+.shelf |
+.svn |
+CVS |
+DEADJOE |
+RCS |
+_MTN |
+_darcs |
+{arch} |
+); |
+## use critic |
+ |
+=over 4 |
+ |
+=item my $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) = @_; |
+ |
+ $diff_ignore_default_regex = $regex; |
+} |
+ |
+=item my @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; |
+} |
+ |
+=item $p = Dpkg::Source::Package->new(filename => $dscfile, options => {}) |
+ |
+Creates a new object corresponding to the source package described |
+by the file $dscfile. |
+ |
+The options hash 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 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 |
+ |
+# Object methods |
+sub new { |
+ my ($this, %args) = @_; |
+ my $class = ref($this) || $this; |
+ my $self = { |
+ fields => Dpkg::Control->new(type => CTRL_PKG_SRC), |
+ options => {}, |
+ checksums => Dpkg::Checksums->new(), |
+ }; |
+ bless $self, $class; |
+ if (exists $args{options}) { |
+ $self->{options} = $args{options}; |
+ } |
+ if (exists $args{filename}) { |
+ $self->initialize($args{filename}); |
+ $self->init_options(); |
+ } |
+ return $self; |
+} |
+ |
+sub init_options { |
+ my ($self) = @_; |
+ # 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-.*$'; |
+ 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'; |
+ # Skip debianization while specific to some formats has an impact |
+ # on code common to all formats |
+ $self->{options}{skip_debianization} ||= 0; |
+} |
+ |
+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 = Dpkg::Control->new(type => CTRL_PKG_SRC); |
+ $fields->load($filename); |
+ $self->{fields} = $fields; |
+ $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; |
+ $self->{fields}{'Format'} = '1.0' |
+ unless exists $self->{fields}{'Format'}; |
+ my $format = $self->{fields}{'Format'}; |
+ |
+ if ($format =~ /^([\d\.]+)(?:\s+\((.*)\))?$/) { |
+ my ($version, $variant, $major, $minor) = ($1, $2, $1, undef); |
+ |
+ if (defined $variant and $variant ne lc $variant) { |
+ error(_g("source package format '%s' is not supported: %s"), |
+ $format, _g('format variant must be in lowercase')); |
+ } |
+ |
+ $major =~ s/\.[\d\.]+$//; |
+ my $module = "Dpkg::Source::Package::V$major"; |
+ $module .= '::' . ucfirst $variant if defined $variant; |
+ eval "require $module; \$minor = \$${module}::CURRENT_MINOR_VERSION;"; |
+ $minor //= 0; |
+ if ($update_format) { |
+ $self->{fields}{'Format'} = "$major.$minor"; |
+ $self->{fields}{'Format'} .= " ($variant)" if defined $variant; |
+ } |
+ if ($@) { |
+ error(_g("source package format '%s' is not supported: %s"), |
+ $format, $@); |
+ } |
+ bless $self, $module; |
+ } else { |
+ error(_g("invalid Format field `%s'"), $format); |
+ } |
+} |
+ |
+=item $p->get_filename() |
+ |
+Returns the filename of the DSC file. |
+ |
+=cut |
+ |
+sub get_filename { |
+ my ($self) = @_; |
+ return $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) = @_; |
+ 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. |
+ |
+=cut |
+ |
+sub check_checksums { |
+ my ($self) = @_; |
+ my $checksums = $self->{checksums}; |
+ # add_from_file verify the checksums if they are already existing |
+ foreach my $file ($checksums->get_files()) { |
+ $checksums->add_from_file($self->{basedir} . $file, key => $file); |
+ } |
+} |
+ |
+sub get_basename { |
+ my ($self, $with_revision) = @_; |
+ my $f = $self->{fields}; |
+ unless (exists $f->{'Source'} and exists $f->{'Version'}) { |
+ error(_g('source and version are required to compute the source basename')); |
+ } |
+ 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() |
+ unless exists $opts{extension}; |
+ $opts{include_main} = 1 unless exists $opts{include_main}; |
+ $opts{include_supplementary} = 1 unless exists $opts{include_supplementary}; |
+ 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 { "$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 $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) = @_; |
+ my $dsc = $self->get_filename(); |
+ my @exec; |
+ |
+ if (find_command('gpgv2')) { |
+ push @exec, 'gpgv2'; |
+ } elsif (find_command('gpgv')) { |
+ push @exec, 'gpgv'; |
+ } elsif (find_command('gpg2')) { |
+ push @exec, 'gpg2', '--no-default-keyring', '-q', '--verify'; |
+ } elsif (find_command('gpg')) { |
+ push @exec, 'gpg', '--no-default-keyring', '-q', '--verify'; |
+ } |
+ if (scalar(@exec)) { |
+ if (defined $ENV{HOME} and -r "$ENV{HOME}/.gnupg/trustedkeys.gpg") { |
+ push @exec, '--keyring', "$ENV{HOME}/.gnupg/trustedkeys.gpg"; |
+ } |
+ foreach my $vendor_keyring (run_vendor_hook('keyrings')) { |
+ if (-r $vendor_keyring) { |
+ push @exec, '--keyring', $vendor_keyring; |
+ } |
+ } |
+ push @exec, $dsc; |
+ |
+ my ($stdout, $stderr); |
+ spawn(exec => \@exec, wait_child => 1, nocheck => 1, |
+ to_string => \$stdout, error_to_string => \$stderr, |
+ timeout => 10); |
+ if (WIFEXITED($?)) { |
+ my $gpg_status = WEXITSTATUS($?); |
+ print { *STDERR } "$stdout$stderr" if $gpg_status; |
+ if ($gpg_status == 1 or ($gpg_status && |
+ $self->{options}{require_valid_signature})) |
+ { |
+ error(_g('failed to verify signature on %s'), $dsc); |
+ } elsif ($gpg_status) { |
+ warning(_g('failed to verify signature on %s'), $dsc); |
+ } |
+ } else { |
+ subprocerr("@exec"); |
+ } |
+ } else { |
+ if ($self->{options}{require_valid_signature}) { |
+ error(_g("could not verify signature on %s since gpg isn't installed"), $dsc); |
+ } else { |
+ warning(_g("could not verify signature on %s since gpg isn't installed"), $dsc); |
+ } |
+ } |
+} |
+ |
+sub parse_cmdline_options { |
+ my ($self, @opts) = @_; |
+ foreach (@opts) { |
+ if (not $self->parse_cmdline_option($_)) { |
+ warning(_g('%s is not a valid option for %s'), $_, 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. |
+ |
+=cut |
+ |
+sub extract { |
+ my $self = shift; |
+ my $newdirectory = $_[0]; |
+ |
+ my ($ok, $error) = version_check($self->{fields}{'Version'}); |
+ error($error) unless $ok; |
+ |
+ # 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)) { |
+ system('cp', '--', $src, $dst); |
+ subprocerr("cp $src to $dst") if $?; |
+ } |
+ } |
+ } |
+ |
+ # Try extract |
+ eval { $self->do_extract(@_) }; |
+ if ($@) { |
+ run_exit_handlers(); |
+ die $@; |
+ } |
+ |
+ # Store format if non-standard so that next build keeps the same format |
+ if ($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; |
+ open(my $format_fh, '>', $format_file) |
+ or syserr(_g('cannot write %s'), $format_file); |
+ print { $format_fh } $self->{fields}{'Format'} . "\n"; |
+ close($format_fh); |
+ } |
+ } |
+ |
+ # 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; |
+ eval { $self->do_build(@_) }; |
+ if ($@) { |
+ run_exit_handlers(); |
+ die $@; |
+ } |
+} |
+ |
+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 overriden'); |
+} |
+ |
+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; |
+ eval { $self->do_commit(@_) }; |
+ if ($@) { |
+ run_exit_handlers(); |
+ die $@; |
+ } |
+} |
+ |
+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)) { |
+ unless (defined($fields->{$f})) { |
+ error(_g('missing information for critical output field %s'), $f); |
+ } |
+ } |
+ foreach my $f (qw(Maintainer Architecture 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}; |
+ unless (defined $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 1.01 |
+ |
+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 |
+ |
+=head1 AUTHOR |
+ |
+Raphaël Hertzog, E<lt>hertzog@debian.orgE<gt> |
+ |
+=cut |
+ |
+1; |