our $VERSION = '1.03';
our @EXPORT_OK = qw(
get_default_diff_ignore_regex
set_default_diff_ignore_regex
get_default_tar_ignore_pattern
);
use POSIX qw(:errno_h :sys_wait_h);use Dpkg::Path qw(check_files_are_the_same find_command);my $diff_ignore_default_regex = '
(?:^|/).*~$|
(?:^|/)\.
(?:^|/)\..*\.sw.$|
(?:^|/),,.*(?:$|/.*$)|
(?:^|/)(?:DEADJOE|\.arch-inventory|\.(?:bzr|cvs|hg|git|mtn-)ignore)$|
(?:^|/)(?:CVS|RCS|\.deps|\{arch\}|\.arch-ids|\.svn|
\.hg(?:tags|sigs)?|_darcs|\.git(?:attributes|modules|review)?|
\.mailmap|\.shelf|_MTN|\.be|\.bzr(?:\.backup|tags)?)(?:$|/.*$)
';
$diff_ignore_default_regex =~ s/^
$diff_ignore_default_regex =~ s/\n//sg;
our $diff_ignore_default_regexp;
*diff_ignore_default_regexp = \$diff_ignore_default_regex;
no warnings 'qw';
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
.gitreview
.hg
.hgignore
.hgsigs
.hgtags
.mailmap
.mtn-ignore
.shelf
.svn
CVS
DEADJOE
RCS
_MTN
_darcs
{arch}
);
sub get_default_diff_ignore_regex {
return $diff_ignore_default_regex;
}
sub set_default_diff_ignore_regex {
my $regex = shift;
$diff_ignore_default_regex = $regex;
}
sub get_default_tar_ignore_pattern {
return @tar_ignore_default_pattern;
}
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(),
};
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();
}
return $self;
}
sub init_options {
my $self = shift;
$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}{skip_debianization} //= 0;
$self->{options}{compression} //= 'xz';
$self->{options}{comp_level} //= compression_get_property($self->{options}{compression},
'default_level');
$self->{options}{comp_ext} //= compression_get_property($self->{options}{compression},
'file_ext');
}
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;
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;
}
sub get_filename {
my $self = shift;
return $self->{basedir} . $self->{filename};
}
sub get_files {
my $self = shift;
return $self->{checksums}->get_files();
}
sub check_checksums {
my $self = shift;
my $checksums = $self->{checksums};
my $warn_on_weak = 0;
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;
}
}
$checksums->add_from_file($self->{basedir} . $file, 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 { "$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;
}
sub is_signed {
my $self = shift;
return $self->{is_signed};
}
sub check_signature {
my $self = shift;
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 (length $ENV{HOME} and -r "$ENV{HOME}/.gnupg/trustedkeys.gpg") {
push @exec, '--keyring', "$ENV{HOME}/.gnupg/trustedkeys.gpg";
}
foreach my $vendor_keyring (run_vendor_hook('package-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_('cannot verify signature on %s since GnuPG is not installed'), $dsc);
} else {
warning(g_('cannot verify signature on %s since GnuPG is not installed'), $dsc);
}
}
}
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;
}
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);
}
}
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 $?;
}
}
}
eval { $self->do_extract($newdirectory) };
if ($@) {
run_exit_handlers();
die $@;
}
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);
}
}
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';
}
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 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;
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 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);
}
1;