| 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;
|
|
|