diff options
author | Igor Pashev <pashev.igor@gmail.com> | 2019-11-26 14:00:30 +0300 |
---|---|---|
committer | Igor Pashev <pashev.igor@gmail.com> | 2019-11-26 14:00:30 +0300 |
commit | 414ea1706306e061fc44a8b5ce3042d4f0728489 (patch) | |
tree | ef0b2c4eac79e479ed686a5d88d7b3b954717824 /scripts/Dpkg | |
parent | ed2b463626bd721942143baa6207f2ccac67a616 (diff) | |
parent | 89afa9af7cd589eb8384ed96b6d86dd59d56bdf5 (diff) | |
download | dpkg-414ea1706306e061fc44a8b5ce3042d4f0728489.tar.gz |
Merge https://salsa.debian.org/dpkg-team/dpkg
Diffstat (limited to 'scripts/Dpkg')
54 files changed, 2883 insertions, 1874 deletions
diff --git a/scripts/Dpkg/Arch.pm b/scripts/Dpkg/Arch.pm index db6be6b2f..531bc118e 100644 --- a/scripts/Dpkg/Arch.pm +++ b/scripts/Dpkg/Arch.pm @@ -36,7 +36,7 @@ use strict; use warnings; use feature qw(state); -our $VERSION = '1.02'; +our $VERSION = '1.03'; our @EXPORT_OK = qw( get_raw_build_arch get_raw_host_arch @@ -601,17 +601,25 @@ sub debarch_is_wildcard($) return 0; } -=item $bool = debarch_is_illegal($arch) +=item $bool = debarch_is_illegal($arch, %options) Validate an architecture name. +If the "positive" option is set to a true value, only positive architectures +will be accepted, otherwise negated architectures are allowed. + =cut sub debarch_is_illegal { - my ($arch) = @_; + my ($arch, %opts) = @_; + my $arch_re = qr/[a-zA-Z0-9][a-zA-Z0-9-]*/; - return $arch !~ m/^!?[a-zA-Z0-9][a-zA-Z0-9-]*$/; + if ($opts{positive}) { + return $arch !~ m/^$arch_re$/; + } else { + return $arch !~ m/^!?$arch_re$/; + } } =item $bool = debarch_is_concerned($arch, @arches) @@ -653,15 +661,18 @@ sub debarch_is_concerned Parse an architecture list. +If the "positive" option is set to a true value, only positive architectures +will be accepted, otherwise negated architectures are allowed. + =cut sub debarch_list_parse { - my $arch_list = shift; + my ($arch_list, %opts) = @_; my @arch_list = split ' ', $arch_list; foreach my $arch (@arch_list) { - if (debarch_is_illegal($arch)) { + if (debarch_is_illegal($arch, %opts)) { error(g_("'%s' is not a legal architecture in list '%s'"), $arch, $arch_list); } @@ -678,6 +689,11 @@ __END__ =head1 CHANGES +=head2 Version 1.03 (dpkg 1.19.1) + +New argument: Accept a "positive" option in debarch_is_illegal() and +debarch_list_parse(). + =head2 Version 1.02 (dpkg 1.18.19) New import tags: ":all", ":getters", ":parsers", ":mappers", ":operators". diff --git a/scripts/Dpkg/Build/Types.pm b/scripts/Dpkg/Build/Types.pm index 45a81d3ba..9fd0344df 100644 --- a/scripts/Dpkg/Build/Types.pm +++ b/scripts/Dpkg/Build/Types.pm @@ -33,6 +33,7 @@ our @EXPORT = qw( build_is set_build_type set_build_type_from_options + set_build_type_from_targets get_build_options_from_type ); @@ -108,6 +109,15 @@ my %build_types = ( any => BUILD_ARCH_DEP, all => BUILD_ARCH_INDEP, ); +my %build_targets = ( + 'clean' => BUILD_SOURCE, + 'build' => BUILD_BINARY, + 'build-arch' => BUILD_ARCH_DEP, + 'build-indep' => BUILD_ARCH_INDEP, + 'binary' => BUILD_BINARY, + 'binary-arch' => BUILD_ARCH_DEP, + 'binary-indep' => BUILD_ARCH_INDEP, +); =back @@ -193,9 +203,10 @@ sub set_build_type $current_option = $build_option; } -=item set_build_type_from_options($build_type, $build_option, %opts) +=item set_build_type_from_options($build_types, $build_option, %opts) -Set the current build type from a list of build type components. +Set the current build type from a list of comma-separated build type +components. The function will check and abort on incompatible build type assignments, this behavior can be disabled by using the boolean option "nocheck". @@ -216,6 +227,28 @@ sub set_build_type_from_options set_build_type($build_type, $build_option, %opts); } +=item set_build_type_from_targets($build_targets, $build_option, %opts) + +Set the current build type from a list of comma-separated build target +components. + +The function will check and abort on incompatible build type assignments, +this behavior can be disabled by using the boolean option "nocheck". + +=cut + +sub set_build_type_from_targets +{ + my ($build_targets, $build_option, %opts) = @_; + + my $build_type = 0; + foreach my $target (split /,/, $build_targets) { + $build_type |= $build_targets{$target} // BUILD_BINARY; + } + + set_build_type($build_type, $build_option, %opts); +} + =item get_build_options_from_type() Get the current build type as a set of comma-separated string options. diff --git a/scripts/Dpkg/BuildFlags.pm b/scripts/Dpkg/BuildFlags.pm index 0533b12b5..53b3cad00 100644 --- a/scripts/Dpkg/BuildFlags.pm +++ b/scripts/Dpkg/BuildFlags.pm @@ -18,12 +18,11 @@ package Dpkg::BuildFlags; use strict; use warnings; -our $VERSION = '1.03'; +our $VERSION = '1.04'; use Dpkg (); use Dpkg::Gettext; use Dpkg::Build::Env; -use Dpkg::BuildOptions; use Dpkg::ErrorHandling; use Dpkg::Vendor qw(run_vendor_hook); @@ -35,7 +34,7 @@ Dpkg::BuildFlags - query build flags =head1 DESCRIPTION -The Dpkg::BuildFlags object is used by dpkg-buildflags and can be used +This class is used by dpkg-buildflags and can be used to query the same information. =head1 METHODS @@ -69,21 +68,16 @@ Reset the flags stored to the default set provided by the vendor. sub load_vendor_defaults { my $self = shift; - $self->{options} = {}; - $self->{source} = {}; $self->{features} = {}; - my $build_opts = Dpkg::BuildOptions->new(); - $self->{build_options} = $build_opts; - my $default_flags = $build_opts->has('noopt') ? '-g -O0' : '-g -O2'; $self->{flags} = { CPPFLAGS => '', - CFLAGS => $default_flags, - CXXFLAGS => $default_flags, - OBJCFLAGS => $default_flags, - OBJCXXFLAGS => $default_flags, - GCJFLAGS => $default_flags, - FFLAGS => $default_flags, - FCFLAGS => $default_flags, + CFLAGS => '', + CXXFLAGS => '', + OBJCFLAGS => '', + OBJCXXFLAGS => '', + GCJFLAGS => '', + FFLAGS => '', + FCFLAGS => '', LDFLAGS => '', }; $self->{origin} = { @@ -218,6 +212,20 @@ sub load_config { $self->load_maintainer_config(); } +=item $bf->unset($flag) + +Unset the build flag $flag, so that it will not be known anymore. + +=cut + +sub unset { + my ($self, $flag) = @_; + + delete $self->{flags}->{$flag}; + delete $self->{origin}->{$flag}; + delete $self->{maintainer}->{$flag}; +} + =item $bf->set($flag, $value, $source, $maint) Update the build flag $flag with value $value and record its origin as @@ -446,6 +454,10 @@ sub list { =head1 CHANGES +=head2 Version 1.04 (dpkg 1.20.0) + +New method: $bf->unset(). + =head2 Version 1.03 (dpkg 1.16.5) New method: $bf->get_feature_areas() to list possible values for diff --git a/scripts/Dpkg/BuildOptions.pm b/scripts/Dpkg/BuildOptions.pm index 057dfc1e3..e03ea320b 100644 --- a/scripts/Dpkg/BuildOptions.pm +++ b/scripts/Dpkg/BuildOptions.pm @@ -34,7 +34,7 @@ Dpkg::BuildOptions - parse and update build options =head1 DESCRIPTION -The Dpkg::BuildOptions object can be used to manipulate options stored +This class can be used to manipulate options stored in environment variables like DEB_BUILD_OPTIONS and DEB_BUILD_MAINT_OPTIONS. @@ -164,7 +164,7 @@ Each feature is prefixed with a ‘B<+>’ or a ‘B<->’ character as a marker to enable or disable it. The special feature “B<all>” can be used to act on all known features. -Unknown of malformed features will emit warnings. +Unknown or malformed features will emit warnings. =cut diff --git a/scripts/Dpkg/Changelog.pm b/scripts/Dpkg/Changelog.pm index db8e3eb09..04fa511ec 100644 --- a/scripts/Dpkg/Changelog.pm +++ b/scripts/Dpkg/Changelog.pm @@ -24,7 +24,7 @@ Dpkg::Changelog - base class to implement a changelog parser Dpkg::Changelog is a class representing a changelog file as an array of changelog entries (Dpkg::Changelog::Entry). -By deriving this object and implementing its parse method, you +By deriving this class and implementing its parse method, you add the ability to fill this object with changelog entries. =cut @@ -34,7 +34,7 @@ package Dpkg::Changelog; use strict; use warnings; -our $VERSION = '1.01'; +our $VERSION = '2.00'; use Carp; @@ -74,12 +74,6 @@ sub new { return $self; } -=item $c->load($filename) - -Parse $filename as a changelog. - -=cut - =item $c->set_options(%opts) Change the value of some options. "verbose" (defaults to 1) defines @@ -96,6 +90,22 @@ sub set_options { $self->{$_} = $opts{$_} foreach keys %opts; } +=item $count = $c->parse($fh, $description) + +Read the filehandle and parse a changelog in it. The data in the object is +reset before parsing new data. + +Returns the number of changelog entries that have been parsed with success. + +This method needs to be implemented by one of the specialized changelog +format subclasses. + +=item $count = $c->load($filename) + +Parse $filename contents for a changelog. + +Returns the number of changelog entries that have been parsed with success. + =item $c->reset_parse_errors() Can be used to delete all information about errors occurred during @@ -254,7 +264,7 @@ sub __sanity_check_range { push @versions, $version->as_string(); } if ((defined($r->{since}) and not exists $versions{$r->{since}})) { - warning(g_("'%s' option specifies non-existing version"), 'since'); + warning(g_("'%s' option specifies non-existing version '%s'"), 'since', $r->{since}); warning(g_('use newest entry that is earlier than the one specified')); foreach my $v (@versions) { if (version_compare_relation($v, REL_LT, $r->{since})) { @@ -270,7 +280,7 @@ sub __sanity_check_range { } } if ((defined($r->{from}) and not exists $versions{$r->{from}})) { - warning(g_("'%s' option specifies non-existing version"), 'from'); + warning(g_("'%s' option specifies non-existing version '%s'"), 'from', $r->{from}); warning(g_('use oldest entry that is later than the one specified')); my $oldest; foreach my $v (@versions) { @@ -281,12 +291,12 @@ sub __sanity_check_range { if (defined($oldest)) { $r->{from} = $oldest; } else { - warning(g_("no such entry found, ignoring '%s' parameter"), 'from'); + warning(g_("no such entry found, ignoring '%s' parameter '%s'"), 'from', $r->{from}); delete $r->{from}; # No version was oldest } } if (defined($r->{until}) and not exists $versions{$r->{until}}) { - warning(g_("'%s' option specifies non-existing version"), 'until'); + warning(g_("'%s' option specifies non-existing version '%s'"), 'until', $r->{until}); warning(g_('use oldest entry that is later than the one specified')); my $oldest; foreach my $v (@versions) { @@ -297,12 +307,12 @@ sub __sanity_check_range { if (defined($oldest)) { $r->{until} = $oldest; } else { - warning(g_("no such entry found, ignoring '%s' parameter"), 'until'); + warning(g_("no such entry found, ignoring '%s' parameter '%s'"), 'until', $r->{until}); delete $r->{until}; # No version was oldest } } if (defined($r->{to}) and not exists $versions{$r->{to}}) { - warning(g_("'%s' option specifies non-existing version"), 'to'); + warning(g_("'%s' option specifies non-existing version '%s'"), 'to', $r->{to}); warning(g_('use newest entry that is earlier than the one specified')); foreach my $v (@versions) { if (version_compare_relation($v, REL_LT, $r->{to})) { @@ -312,17 +322,17 @@ sub __sanity_check_range { } if (not exists $versions{$r->{to}}) { # No version was earlier - warning(g_("no such entry found, ignoring '%s' parameter"), 'to'); + warning(g_("no such entry found, ignoring '%s' parameter '%s'"), 'to', $r->{to}); delete $r->{to}; } } if (defined($r->{since}) and $data->[0]->get_version() eq $r->{since}) { - warning(g_("'since' option specifies most recent version, ignoring")); + warning(g_("'since' option specifies most recent version '%s', ignoring"), $r->{since}); delete $r->{since}; } if (defined($r->{until}) and $data->[-1]->get_version() eq $r->{until}) { - warning(g_("'until' option specifies oldest version, ignoring")); + warning(g_("'until' option specifies oldest version '%s', ignoring"), $r->{until}); delete $r->{until}; } ## use critic @@ -332,11 +342,12 @@ sub get_range { my ($self, $range) = @_; $range //= {}; my $res = $self->_data_range($range); - if (defined $res) { - return @$res if wantarray; - return $res; + return unless defined $res; + if (wantarray) { + return reverse @{$res} if $range->{reverse}; + return @{$res}; } else { - return; + return $res; } } @@ -442,11 +453,7 @@ sub abort_early { return; } -=item $c->save($filename) - -Save the changelog in the given file. - -=item $c->output() +=item $str = $c->output() =item "$c" @@ -475,6 +482,12 @@ sub output { return $str; } +=item $c->save($filename) + +Save the changelog in the given file. + +=cut + our ( @URGENCIES, %URGENCIES ); BEGIN { @URGENCIES = qw(low medium high critical emergency); @@ -657,36 +670,6 @@ sub format_range { } } -=item $control = $c->dpkg($range) - -This is a deprecated alias for $c->format_range('dpkg', $range). - -=cut - -sub dpkg { - my ($self, $range) = @_; - - warnings::warnif('deprecated', - 'deprecated method, please use format_range("dpkg", $range) instead'); - - return $self->format_range('dpkg', $range); -} - -=item @controls = $c->rfc822($range) - -This is a deprecated alias for C<scalar c->format_range('rfc822', $range)>. - -=cut - -sub rfc822 { - my ($self, $range) = @_; - - warnings::warnif('deprecated', - 'deprecated method, please use format_range("rfc822", $range) instead'); - - return scalar $self->format_range('rfc822', $range); -} - =back =head1 RANGE SELECTION @@ -766,6 +749,10 @@ with only one of the options specified. =head1 CHANGES +=head2 Version 2.00 (dpkg 1.20.0) + +Remove methods: $c->dpkg(), $c->rfc822(). + =head2 Version 1.01 (dpkg 1.18.8) New method: $c->format_range(). diff --git a/scripts/Dpkg/Changelog/Debian.pm b/scripts/Dpkg/Changelog/Debian.pm index a44ac666c..a85f3af12 100644 --- a/scripts/Dpkg/Changelog/Debian.pm +++ b/scripts/Dpkg/Changelog/Debian.pm @@ -24,6 +24,12 @@ Dpkg::Changelog::Debian - parse Debian changelogs =head1 DESCRIPTION +This class represents a Debian changelog file as an array of changelog +entries (Dpkg::Changelog::Entry::Debian). +It implements the generic interface Dpkg::Changelog. +Only methods specific to this implementation are described below, +the rest are inherited. + Dpkg::Changelog::Debian parses Debian changelogs as described in deb-changelog(5). @@ -118,10 +124,11 @@ my $ancient_delimiter_re = qr{ =over 4 -=item $c->parse($fh, $description) +=item $count = $c->parse($fh, $description) -Read the filehandle and parse a Debian changelog in it. The data in the -object is reset before parsing new data. +Read the filehandle and parse a Debian changelog in it, to store the entries +as an array of Dpkg::Changelog::Entry::Debian objects. +Any previous entries in the object are reset before parsing new data. Returns the number of changelog entries that have been parsed with success. @@ -162,9 +169,13 @@ sub parse { $expect= START_CHANGES; @blanklines = (); } elsif (m/^(?:;;\s*)?Local variables:/io) { - last; # skip Emacs variables at end of file + # Save any trailing Emacs variables at end of file. + $self->set_unparsed_tail("$_\n" . (file_slurp($fh) // '')); + last; } elsif (m/^vim:/io) { - last; # skip Vim modelines at end of file + # Save any trailing Vim modelines at end of file. + $self->set_unparsed_tail("$_\n" . (file_slurp($fh) // '')); + last; } elsif (m/^\$\w+:.*\$/o) { next; # skip stuff that look like a RCS keyword } elsif (m/^\# /o) { diff --git a/scripts/Dpkg/Changelog/Entry.pm b/scripts/Dpkg/Changelog/Entry.pm index 144dacb0f..d6ce55601 100644 --- a/scripts/Dpkg/Changelog/Entry.pm +++ b/scripts/Dpkg/Changelog/Entry.pm @@ -39,7 +39,7 @@ Dpkg::Changelog::Entry - represents a changelog entry =head1 DESCRIPTION -This object represents a changelog entry. It is composed +This class represents a changelog entry. It is composed of a set of lines with specific purpose: an header line, changes lines, a trailer line. Blank lines can be between those kind of lines. diff --git a/scripts/Dpkg/Changelog/Entry/Debian.pm b/scripts/Dpkg/Changelog/Entry/Debian.pm index 3d1888638..1e7daf55b 100644 --- a/scripts/Dpkg/Changelog/Entry/Debian.pm +++ b/scripts/Dpkg/Changelog/Entry/Debian.pm @@ -19,10 +19,8 @@ package Dpkg::Changelog::Entry::Debian; use strict; use warnings; -our $VERSION = '1.03'; +our $VERSION = '2.00'; our @EXPORT_OK = qw( - $regex_header - $regex_trailer match_header match_trailer find_closes @@ -47,20 +45,18 @@ Dpkg::Changelog::Entry::Debian - represents a Debian changelog entry =head1 DESCRIPTION -This object represents a Debian changelog entry. It implements the -generic interface Dpkg::Changelog::Entry. Only functions specific to this -implementation are described below. +This class represents a Debian changelog entry. +It implements the generic interface Dpkg::Changelog::Entry. +Only functions specific to this implementation are described below, +the rest are inherited. =cut my $name_chars = qr/[-+0-9a-z.]/i; -# XXX: Backwards compatibility, stop exporting on VERSION 2.00. -## no critic (Variables::ProhibitPackageVars) - # The matched content is the source package name ($1), the version ($2), # the target distributions ($3) and the options on the rest of the line ($4). -our $regex_header = qr{ +my $regex_header = qr{ ^ (\w$name_chars*) # Package name \ \(([^\(\) \t]+)\) # Package version @@ -73,7 +69,7 @@ our $regex_header = qr{ # The matched content is the maintainer name ($1), its email ($2), # some blanks ($3) and the timestamp ($4), which is decomposed into # day of week ($6), date-time ($7) and this into month name ($8). -our $regex_trailer = qr< +my $regex_trailer = qr< ^ \ \-\- # Trailer marker \ (.*) # Maintainer name @@ -100,8 +96,6 @@ my %month_name = map { $_ => } qw( August September October November December ); -## use critic - =head1 METHODS =over 4 @@ -236,7 +230,7 @@ sub parse_trailer { push @errors, sprintf(g_('invalid abbreviated month name \'%s\''), $8); } } - push @errors, sprintf(g_("cannot parse non-comformant date '%s'"), $7); + push @errors, sprintf(g_("cannot parse non-conformant date '%s'"), $7); }; $self->{trailer_timestamp_date} = $4; } else { @@ -245,36 +239,6 @@ sub parse_trailer { return @errors; } -=item $entry->check_header() - -Obsolete method. Use parse_header() instead. - -=cut - -sub check_header { - my $self = shift; - - warnings::warnif('deprecated', - 'obsolete check_header(), use parse_header() instead'); - - return $self->parse_header(); -} - -=item $entry->check_trailer() - -Obsolete method. Use parse_trailer() instead. - -=cut - -sub check_trailer { - my $self = shift; - - warnings::warnif('deprecated', - 'obsolete check_trailer(), use parse_trailer() instead'); - - return $self->parse_header(); -} - =item $entry->normalize() Normalize the content. Strip whitespaces at end of lines, use a single @@ -465,6 +429,12 @@ sub find_closes { =head1 CHANGES +=head2 Version 2.00 (dpkg 1.20.0) + +Remove methods: $entry->check_header(), $entry->check_trailer(). + +Hide variables: $regex_header, $regex_trailer. + =head2 Version 1.03 (dpkg 1.18.8) New methods: $entry->get_timepiece(). diff --git a/scripts/Dpkg/Changelog/Parse.pm b/scripts/Dpkg/Changelog/Parse.pm index e107dcf6d..8140e25a6 100644 --- a/scripts/Dpkg/Changelog/Parse.pm +++ b/scripts/Dpkg/Changelog/Parse.pm @@ -33,10 +33,8 @@ package Dpkg::Changelog::Parse; use strict; use warnings; -our $VERSION = '1.03'; +our $VERSION = '2.00'; our @EXPORT = qw( - changelog_parse_debian - changelog_parse_plugin changelog_parse ); @@ -56,12 +54,16 @@ sub _changelog_detect_format { if ($file ne '-') { local $_; - open my $format_fh, '-|', 'tail', '-n', '40', $file - or syserr(g_('cannot create pipe for %s'), 'tail'); + open my $format_fh, '<', $file + or syserr(g_('cannot open file %s'), $file); + if (-s $format_fh > 4096) { + seek $format_fh, -4096, 2 + or syserr(g_('cannot seek into file %s'), $file); + } while (<$format_fh>) { $format = $1 if m/\schangelog-format:\s+([0-9a-z]+)\W/; } - close $format_fh or subprocerr(g_('tail of %s'), $file); + close $format_fh; } return $format; @@ -71,40 +73,6 @@ sub _changelog_detect_format { =over 4 -=item $fields = changelog_parse_debian(%opt) - -This function is deprecated, use changelog_parse() instead, with the changelog -format set to "debian". - -=cut - -sub changelog_parse_debian { - my (%options) = @_; - - warnings::warnif('deprecated', - 'deprecated function changelog_parse_debian, use changelog_parse instead'); - - # Force the plugin to be debian. - $options{changelogformat} = 'debian'; - - return _changelog_parse(%options); -} - -=item $fields = changelog_parse_plugin(%opt) - -This function is deprecated, use changelog_parse() instead. - -=cut - -sub changelog_parse_plugin { - my (%options) = @_; - - warnings::warnif('deprecated', - 'deprecated function changelog_parse_plugin, use changelog_parse instead'); - - return _changelog_parse(%options); -} - =item $fields = changelog_parse(%opt) This function will parse a changelog. In list context, it returns as many @@ -133,22 +101,16 @@ All the other keys in %opt are forwarded to the parser module constructor. =cut -sub _changelog_parse { +sub changelog_parse { my (%options) = @_; - # Setup and sanity checks. - if (exists $options{libdir}) { - warnings::warnif('deprecated', - 'obsolete libdir option, changelog parsers are now perl modules'); - } - $options{file} //= 'debian/changelog'; $options{label} //= $options{file}; $options{changelogformat} //= _changelog_detect_format($options{file}); $options{format} //= 'dpkg'; $options{compression} //= $options{file} ne 'debian/changelog'; - my @range_opts = qw(since until from to offset count all); + my @range_opts = qw(since until from to offset count reverse all); $options{all} = 1 if exists $options{all}; if (none { defined $options{$_} } @range_opts) { $options{count} = 1; @@ -191,19 +153,15 @@ sub _changelog_parse { } } -sub changelog_parse { - my (%options) = @_; +=back - if (exists $options{forceplugin}) { - warnings::warnif('deprecated', 'obsolete forceplugin option'); - } +=head1 CHANGES - return _changelog_parse(%options); -} +=head2 Version 2.00 (dpkg 1.20.0) -=back +Remove functions: changelog_parse_debian(), changelog_parse_plugin(). -=head1 CHANGES +Remove warnings: For options 'forceplugin', 'libdir'. =head2 Version 1.03 (dpkg 1.19.0) @@ -213,7 +171,7 @@ New option: 'compression' in changelog_parse(). Deprecated functions: changelog_parse_debian(), changelog_parse_plugin(). -Obsolete options: $forceplugin, $libdir. +Obsolete options: forceplugin, libdir. =head2 Version 1.01 (dpkg 1.18.2) diff --git a/scripts/Dpkg/Checksums.pm b/scripts/Dpkg/Checksums.pm index 1237e8b89..93bdf4bd8 100644 --- a/scripts/Dpkg/Checksums.pm +++ b/scripts/Dpkg/Checksums.pm @@ -20,7 +20,7 @@ package Dpkg::Checksums; use strict; use warnings; -our $VERSION = '1.03'; +our $VERSION = '1.04'; our @EXPORT = qw( checksums_is_supported checksums_get_list @@ -41,7 +41,7 @@ Dpkg::Checksums - generate and manipulate file checksums =head1 DESCRIPTION -This module provides an object that can generate and manipulate +This module provides a class that can generate and manipulate various file checksums as well as some methods to query information about supported checksums. @@ -106,10 +106,6 @@ whether the checksum algorithm is considered cryptographically strong. sub checksums_get_property($$) { my ($alg, $property) = @_; - if ($property eq 'program') { - warnings::warnif('deprecated', 'obsolete checksums program property'); - } - return unless checksums_is_supported($alg); return $CHECKSUMS->{lc($alg)}{$property}; } @@ -400,6 +396,10 @@ sub export_to_control { =head1 CHANGES +=head2 Version 1.04 (dpkg 1.20.0) + +Remove warning: For obsolete property 'program'. + =head2 Version 1.03 (dpkg 1.18.5) New property: Add new 'strong' property. diff --git a/scripts/Dpkg/Compression.pm b/scripts/Dpkg/Compression.pm index 3dbc4adf0..5bbe7f427 100644 --- a/scripts/Dpkg/Compression.pm +++ b/scripts/Dpkg/Compression.pm @@ -19,9 +19,8 @@ package Dpkg::Compression; use strict; use warnings; -our $VERSION = '1.02'; +our $VERSION = '2.00'; our @EXPORT = qw( - $compression_re_file_ext compression_is_supported compression_get_list compression_get_property @@ -98,14 +97,11 @@ if ($Config{cf_by} eq 'Debian Project') { push @{$COMP->{gzip}->{comp_prog}}, '--rsyncable'; } -# XXX: Backwards compatibility, stop exporting on VERSION 2.00. -## no critic (Variables::ProhibitPackageVars) -our $default_compression = 'xz'; -our $default_compression_level = undef; +my $default_compression = 'xz'; +my $default_compression_level = undef; my $regex = join '|', map { $_->{file_ext} } values %$COMP; -our $compression_re_file_ext = qr/(?:$regex)/; -## use critic +my $compression_re_file_ext = qr/(?:$regex)/; =head1 FUNCTIONS @@ -250,6 +246,11 @@ sub compression_is_valid_level { =head1 CHANGES +=head2 Version 2.00 (dpkg 1.20.0) + +Hide variables: $default_compression, $default_compression_level +and $compression_re_file_ext. + =head2 Version 1.02 (dpkg 1.17.2) New function: compression_get_file_extension_regex() diff --git a/scripts/Dpkg/Compression/FileHandle.pm b/scripts/Dpkg/Compression/FileHandle.pm index 23b39841a..c0d4b0787 100644 --- a/scripts/Dpkg/Compression/FileHandle.pm +++ b/scripts/Dpkg/Compression/FileHandle.pm @@ -31,14 +31,14 @@ use Dpkg::ErrorHandling; use parent qw(IO::File Tie::Handle); # Useful reference to understand some kludges required to -# have the object behave like a filehandle +# have the class behave like a filehandle # http://blog.woobling.org/2009/10/are-filehandles-objects.html =encoding utf8 =head1 NAME -Dpkg::Compression::FileHandle - object dealing transparently with file compression +Dpkg::Compression::FileHandle - class dealing transparently with file compression =head1 SYNOPSIS @@ -76,7 +76,7 @@ Dpkg::Compression::FileHandle - object dealing transparently with file compressi =head1 DESCRIPTION -Dpkg::Compression::FileHandle is an object that can be used +Dpkg::Compression::FileHandle is a class that can be used like any filehandle and that deals transparently with compressed files. By default, the compression scheme is guessed from the filename but you can override this behaviour with the method C<set_compression>. @@ -102,8 +102,8 @@ and you can't seek on a pipe. =head1 FileHandle METHODS -The object inherits from IO::File so all methods that work on this -object should work for Dpkg::Compression::FileHandle too. There +The class inherits from IO::File so all methods that work on this +class should work for Dpkg::Compression::FileHandle too. There may be exceptions though. =head1 PUBLIC METHODS @@ -121,7 +121,7 @@ obviously incompatible with automatic detection of the compression method. =cut -# Object methods +# Class methods sub new { my ($this, %args) = @_; my $class = ref($this) || $this; @@ -378,7 +378,7 @@ sub use_compression { =item $real_fh = $fh->get_filehandle() Returns the real underlying filehandle. Useful if you want to pass it -along in a derived object. +along in a derived class. =cut @@ -444,9 +444,9 @@ sub _cleanup { =back -=head1 DERIVED OBJECTS +=head1 DERIVED CLASSES -If you want to create an object that inherits from +If you want to create a class that inherits from Dpkg::Compression::FileHandle you must be aware that the object is a reference to a GLOB that is returned by Symbol::gensym() and as such it's not a HASH. diff --git a/scripts/Dpkg/Conf.pm b/scripts/Dpkg/Conf.pm index ca98cd3a7..028a2939f 100644 --- a/scripts/Dpkg/Conf.pm +++ b/scripts/Dpkg/Conf.pm @@ -18,7 +18,7 @@ package Dpkg::Conf; use strict; use warnings; -our $VERSION = '1.03'; +our $VERSION = '1.04'; use Carp; @@ -85,22 +85,6 @@ sub get_options { return @{$self->{options}}; } -=item get() - -=item set() - -Obsolete functions, use get_options() instead. They will croak. - -=cut - -sub get { - croak 'obsolete function, use get_options instead'; -} - -sub set { - croak 'obsolete function, use get_options instead'; -} - =item $conf->load($file) Read options from a file. Return the number of options parsed. @@ -215,13 +199,11 @@ sub filter { my $remove = $opts{remove} // sub { 0 }; my $keep = $opts{keep} // sub { 1 }; - croak 'obsolete option format_argv' if exists $opts{format_argv}; - @{$self->{options}} = grep { not $remove->($_) and $keep->($_) } @{$self->{options}}; } -=item $string = $conf->output($fh) +=item $string = $conf->output([$fh]) Write the options in the given filehandle (if defined) and return a string representation of the content (that would be) written. @@ -230,10 +212,6 @@ representation of the content (that would be) written. Return a string representation of the content. -=item $conf->save($file) - -Save the options in a file. - =cut sub output { @@ -249,10 +227,20 @@ sub output { return $ret; } +=item $conf->save($file) + +Save the options in a file. + =back =head1 CHANGES +=head2 Version 1.04 (dpkg 1.20.0) + +Remove croak: For 'format_argv' in $conf->filter(). + +Remove methods: $conf->get(), $conf->set(). + =head2 Version 1.03 (dpkg 1.18.8) Obsolete option: 'format_argv' in $conf->filter(). diff --git a/scripts/Dpkg/Control/Changelog.pm b/scripts/Dpkg/Control/Changelog.pm index 1f65127c4..9184cedbc 100644 --- a/scripts/Dpkg/Control/Changelog.pm +++ b/scripts/Dpkg/Control/Changelog.pm @@ -32,7 +32,7 @@ Dpkg::Control::Changelog - represent info fields output by dpkg-parsechangelog =head1 DESCRIPTION -This object derives directly from Dpkg::Control with the type +This class derives directly from Dpkg::Control with the type CTRL_CHANGELOG. =head1 METHODS diff --git a/scripts/Dpkg/Control/Fields.pm b/scripts/Dpkg/Control/Fields.pm index 4a584e413..33beeec56 100644 --- a/scripts/Dpkg/Control/Fields.pm +++ b/scripts/Dpkg/Control/Fields.pm @@ -32,11 +32,14 @@ foreach my $op (run_vendor_hook('register-custom-fields')) { next if not (defined $op and ref $op); # Skip when not implemented by vendor my $func = shift @$op; if ($func eq 'register') { - &field_register(@$op); + my ($field, $allowed_type, @opts) = @{$op}; + field_register($field, $allowed_type, @opts); } elsif ($func eq 'insert_before') { - &field_insert_before(@$op); + my ($type, $ref, @fields) = @{$op}; + field_insert_before($type, $ref, @fields); } elsif ($func eq 'insert_after') { - &field_insert_after(@$op); + my ($type, $ref, @fields) = @{$op}; + field_insert_after($type, $ref, @fields); } else { croak "vendor hook register-custom-fields sent bad data: @$op"; } diff --git a/scripts/Dpkg/Control/FieldsCore.pm b/scripts/Dpkg/Control/FieldsCore.pm index b100366e1..f460433fc 100644 --- a/scripts/Dpkg/Control/FieldsCore.pm +++ b/scripts/Dpkg/Control/FieldsCore.pm @@ -176,6 +176,11 @@ our %FIELDS = ( allowed => CTRL_INFO_PKG, separator => FIELD_SEP_SPACE, }, + 'build-tainted-by' => { + name => 'Build-Tainted-By', + allowed => CTRL_FILE_BUILDINFO, + separator => FIELD_SEP_SPACE, + }, 'built-for-profiles' => { name => 'Built-For-Profiles', allowed => ALL_PKG | CTRL_FILE_CHANGES, @@ -634,7 +639,7 @@ our %FIELD_ORDER = ( qw(format source binary architecture version binary-only-changes), @src_checksums_fields, qw(build-origin build-architecture build-kernel-version build-date - build-path installed-build-depends environment), + build-path build-tainted-by installed-build-depends environment), ], CTRL_FILE_CHANGES() => [ qw(format date source binary binary-only built-for-profiles architecture diff --git a/scripts/Dpkg/Control/HashCore.pm b/scripts/Dpkg/Control/HashCore.pm index e83522729..04a8a574b 100644 --- a/scripts/Dpkg/Control/HashCore.pm +++ b/scripts/Dpkg/Control/HashCore.pm @@ -43,7 +43,7 @@ Dpkg::Control::HashCore - parse and manipulate a block of RFC822-like fields =head1 DESCRIPTION -The Dpkg::Control::Hash object is a hash-like representation of a set of +The Dpkg::Control::Hash class is a hash-like representation of a set of RFC822-like fields. The fields names are case insensitive and are always capitalized the same when output (see field_capitalize function in Dpkg::Control::Fields). @@ -160,11 +160,6 @@ sub get_option { return $$self->{$k}; } -=item $c->load($file) - -Parse the content of $file. Exits in case of errors. Returns true if some -fields have been parsed. - =item $c->parse_error($file, $fmt, ...) Prints an error message and dies on syntax parse errors. @@ -284,6 +279,11 @@ sub parse { return defined($cf); } +=item $c->load($file) + +Parse the content of $file. Exits in case of errors. Returns true if some +fields have been parsed. + =item $c->find_custom_field($name) Scan the fields and look for a user specific field whose name matches the @@ -313,11 +313,6 @@ sub get_custom_field { return; } -=item $c->save($filename) - -Write the string representation of the control information to a -file. - =item $str = $c->output() =item "$c" @@ -386,6 +381,10 @@ sub output { return $str; } +=item $c->save($filename) + +Write the string representation of the control information to a file. + =item $c->set_output_order(@fields) Define the order in which fields will be displayed in the output() method. @@ -441,7 +440,7 @@ sub apply_substvars { package Dpkg::Control::HashCore::Tie; -# This object is used to tie a hash. It implements hash-like functions by +# This class is used to tie a hash. It implements hash-like functions by # normalizing the name of fields received in keys (using # Dpkg::Control::Fields::field_capitalize). It also stores the order in # which fields have been added in order to be able to dump them in the diff --git a/scripts/Dpkg/Control/Info.pm b/scripts/Dpkg/Control/Info.pm index a5eae8732..5759ab5ad 100644 --- a/scripts/Dpkg/Control/Info.pm +++ b/scripts/Dpkg/Control/Info.pm @@ -38,7 +38,7 @@ Dpkg::Control::Info - parse files like debian/control =head1 DESCRIPTION -It provides an object to access data of files that follow the same +It provides a class to access data of files that follow the same syntax as F<debian/control>. =head1 METHODS @@ -90,11 +90,6 @@ sub reset { $self->{packages} = []; } -=item $c->load($file) - -Load the content of $file. Exits in case of errors. If file is "-", it -loads from the standard input. - =item $c->parse($fh, $description) Parse a control file from the given filehandle. Exits in case of errors. @@ -129,6 +124,11 @@ sub parse { } } +=item $c->load($file) + +Load the content of $file. Exits in case of errors. If file is "-", it +loads from the standard input. + =item $c->[0] =item $c->get_source() @@ -182,9 +182,10 @@ sub get_packages { return @{$self->{packages}}; } -=item $c->output($filehandle) +=item $str = $c->output([$fh]) -Dump the content into a filehandle. +Return the content info into a string. If $fh is specified print it into +the filehandle. =cut diff --git a/scripts/Dpkg/Control/Tests.pm b/scripts/Dpkg/Control/Tests.pm index 439eee8c8..3c8d1c006 100644 --- a/scripts/Dpkg/Control/Tests.pm +++ b/scripts/Dpkg/Control/Tests.pm @@ -34,7 +34,7 @@ Dpkg::Control::Tests - parse files like debian/tests/control =head1 DESCRIPTION -It provides an object to access data of files that follow the same +It provides a class to access data of files that follow the same syntax as F<debian/tests/control>. =head1 METHODS diff --git a/scripts/Dpkg/Control/Tests/Entry.pm b/scripts/Dpkg/Control/Tests/Entry.pm index 92eea49f4..001a6f429 100644 --- a/scripts/Dpkg/Control/Tests/Entry.pm +++ b/scripts/Dpkg/Control/Tests/Entry.pm @@ -34,7 +34,7 @@ Dpkg::Control::Tests::Entry - represents a test suite entry =head1 DESCRIPTION -This object represents a test suite entry. +This class represents a test suite entry. =head1 METHODS diff --git a/scripts/Dpkg/Deps.pm b/scripts/Dpkg/Deps.pm index 3560e1a72..80d249019 100644 --- a/scripts/Dpkg/Deps.pm +++ b/scripts/Dpkg/Deps.pm @@ -1,3 +1,8 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery # Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2008-2009,2012-2014 Guillem Jover <guillem@debian.org> # @@ -13,14 +18,6 @@ # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. -######################################################################### -# Several parts are inspired by lib/Dep.pm from lintian (same license) -# -# Copyright © 1998 Richard Braakman -# Portions Copyright © 1999 Darren Benham -# Portions Copyright © 2000 Sean 'Shaleh' Perry -# Portions Copyright © 2004 Frank Lichtenheld -# Portions Copyright © 2006 Russ Allbery package Dpkg::Deps; @@ -32,7 +29,7 @@ Dpkg::Deps - parse and manipulate dependencies of Debian packages =head1 DESCRIPTION -The Dpkg::Deps module provides objects implementing various types of +The Dpkg::Deps module provides classes implementing various types of dependencies. The most important function is deps_parse(), it turns a dependency line in @@ -49,7 +46,7 @@ All the deps_* functions are exported by default. use strict; use warnings; -our $VERSION = '1.06'; +our $VERSION = '1.07'; our @EXPORT = qw( deps_concat deps_parse @@ -66,6 +63,11 @@ use Dpkg::Arch qw(get_host_arch get_build_arch debarch_to_debtuple); use Dpkg::BuildProfiles qw(get_build_profiles); use Dpkg::ErrorHandling; use Dpkg::Gettext; +use Dpkg::Deps::Simple; +use Dpkg::Deps::Union; +use Dpkg::Deps::AND; +use Dpkg::Deps::OR; +use Dpkg::Deps::KnownFacts; =item deps_eval_implication($rel_p, $v_p, $rel_q, $v_q) @@ -233,6 +235,12 @@ them if set. If set to 1, returns a Dpkg::Deps::Union instead of a Dpkg::Deps::AND. Use this when parsing non-dependency fields like Conflicts. +=item virtual (defaults to 0) + +If set to 1, allow only virtual package version relations, that is none, +or “=”. +This should be set whenever working with Provides fields. + =item build_dep (defaults to 0) If set to 1, allow build-dep only arch qualifiers, that is “:native”. @@ -263,6 +271,7 @@ sub deps_parse { $options{reduce_profiles} //= 0; $options{reduce_restrictions} //= 0; $options{union} //= 0; + $options{virtual} //= 0; $options{build_dep} //= 0; $options{tests_dep} //= 0; @@ -299,6 +308,12 @@ sub deps_parse { warning(g_("can't parse dependency %s"), $dep_or); return; } + if ($options{virtual} && defined $dep_simple->{relation} && + $dep_simple->{relation} ne '=') { + warning(g_('virtual dependency contains invalid relation: %s'), + $dep_simple->output); + return; + } $dep_simple->{arches} = undef if not $options{use_arch}; if ($options{reduce_arch}) { $dep_simple->reduce_arch($options{host_arch}); @@ -414,15 +429,12 @@ sub deps_compare { } } - -package Dpkg::Deps::Simple; - -=head1 OBJECTS - Dpkg::Deps::* +=head1 CLASSES - Dpkg::Deps::* There are several kind of dependencies. A Dpkg::Deps::Simple dependency represents a single dependency statement (it relates to one package only). -Dpkg::Deps::Multiple dependencies are built on top of this object -and combine several dependencies in a different manners. Dpkg::Deps::AND +Dpkg::Deps::Multiple dependencies are built on top of this class +and combine several dependencies in different manners. Dpkg::Deps::AND represents the logical "AND" between dependencies while Dpkg::Deps::OR represents the logical "OR". Dpkg::Deps::Multiple objects can contain Dpkg::Deps::Simple object as well as other Dpkg::Deps::Multiple objects. @@ -431,1101 +443,16 @@ In practice, the code is only meant to handle the realistic cases which, given Debian's dependencies structure, imply those restrictions: AND can contain Simple or OR objects, OR can only contain Simple objects. -Dpkg::Deps::KnownFacts is a special object that is used while evaluating +Dpkg::Deps::KnownFacts is a special class that is used while evaluating dependencies and while trying to simplify them. It represents a set of installed packages along with the virtual packages that they might provide. -=head2 COMMON METHODS - -=over 4 - -=item $dep->is_empty() - -Returns true if the dependency is empty and doesn't contain any useful -information. This is true when a Dpkg::Deps::Simple object has not yet -been initialized or when a (descendant of) Dpkg::Deps::Multiple contains -an empty list of dependencies. - -=item $dep->get_deps() - -Returns a list of sub-dependencies. For Dpkg::Deps::Simple it returns -itself. - -=item $dep->output([$fh]) - -=item "$dep" - -Returns a string representing the dependency. If $fh is set, it prints -the string to the filehandle. - -=item $dep->implies($other_dep) - -Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies -NOT($other_dep). Returns undef when there's no implication. $dep and -$other_dep do not need to be of the same type. - -=item $dep->sort() - -Sorts alphabetically the internal list of dependencies. It's a no-op for -Dpkg::Deps::Simple objects. - -=item $dep->arch_is_concerned($arch) - -Returns true if the dependency applies to the indicated architecture. For -multiple dependencies, it returns true if at least one of the -sub-dependencies apply to this architecture. - -=item $dep->reduce_arch($arch) - -Simplifies the dependency to contain only information relevant to the given -architecture. A Dpkg::Deps::Simple object can be left empty after this -operation. For Dpkg::Deps::Multiple objects, the non-relevant -sub-dependencies are simply removed. - -This trims off the architecture restriction list of Dpkg::Deps::Simple -objects. - -=item $dep->get_evaluation($facts) - -Evaluates the dependency given a list of installed packages and a list of -virtual packages provided. Those lists are part of the -Dpkg::Deps::KnownFacts object given as parameters. - -Returns 1 when it's true, 0 when it's false, undef when some information -is lacking to conclude. - -=item $dep->simplify_deps($facts, @assumed_deps) - -Simplifies the dependency as much as possible given the list of facts (see -object Dpkg::Deps::KnownFacts) and a list of other dependencies that are -known to be true. - -=item $dep->has_arch_restriction() - -For a simple dependency, returns the package name if the dependency -applies only to a subset of architectures. For multiple dependencies, it -returns the list of package names that have such a restriction. - -=item $dep->reset() - -Clears any dependency information stored in $dep so that $dep->is_empty() -returns true. - -=back - -=head2 Dpkg::Deps::Simple - -Such an object has four interesting properties: - -=over 4 - -=item package - -The package name (can be undef if the dependency has not been initialized -or if the simplification of the dependency lead to its removal). - -=item relation - -The relational operator: "=", "<<", "<=", ">=" or ">>". It can be -undefined if the dependency had no version restriction. In that case the -following field is also undefined. - -=item version - -The version. - -=item arches - -The list of architectures where this dependency is applicable. It's -undefined when there's no restriction, otherwise it's an -array ref. It can contain an exclusion list, in that case each -architecture is prefixed with an exclamation mark. - -=item archqual - -The arch qualifier of the dependency (can be undef if there's none). -In the dependency "python:any (>= 2.6)", the arch qualifier is "any". - -=back - -=head3 METHODS - -=over 4 - -=item $simple_dep->parse_string('dpkg-dev (>= 1.14.8) [!hurd-i386]') - -Parses the dependency and modifies internal properties to match the parsed -dependency. - -=item $simple_dep->merge_union($other_dep) - -Returns true if $simple_dep could be modified to represent the union of -both dependencies. Otherwise returns false. - -=back - -=cut - -use strict; -use warnings; - -use Carp; - -use Dpkg::Arch qw(debarch_is_concerned debarch_list_parse); -use Dpkg::BuildProfiles qw(parse_build_profiles evaluate_restriction_formula); -use Dpkg::Version; -use Dpkg::ErrorHandling; -use Dpkg::Gettext; - -use parent qw(Dpkg::Interface::Storable); - -sub new { - my ($this, $arg, %opts) = @_; - my $class = ref($this) || $this; - my $self = {}; - bless $self, $class; - $self->reset(); - $self->{host_arch} = $opts{host_arch}; - $self->{build_arch} = $opts{build_arch}; - $self->{build_dep} = $opts{build_dep} // 0; - $self->{tests_dep} = $opts{tests_dep} // 0; - $self->parse_string($arg) if defined($arg); - return $self; -} - -sub reset { - my $self = shift; - $self->{package} = undef; - $self->{relation} = undef; - $self->{version} = undef; - $self->{arches} = undef; - $self->{archqual} = undef; - $self->{restrictions} = undef; -} - -sub parse { - my ($self, $fh, $desc) = @_; - my $line = <$fh>; - chomp($line); - return $self->parse_string($line); -} - -sub parse_string { - my ($self, $dep) = @_; - - my $pkgname_re; - if ($self->{tests_dep}) { - $pkgname_re = qr/[\@a-zA-Z0-9][\@a-zA-Z0-9+.-]*/; - } else { - $pkgname_re = qr/[a-zA-Z0-9][a-zA-Z0-9+.-]*/; - } - - return if not $dep =~ - m{^\s* # skip leading whitespace - ($pkgname_re) # package name - (?: # start of optional part - : # colon for architecture - ([a-zA-Z0-9][a-zA-Z0-9-]*) # architecture name - )? # end of optional part - (?: # start of optional part - \s* \( # open parenthesis for version part - \s* (<<|<=|=|>=|>>|[<>]) # relation part - \s* ([^\)\s]+) # do not attempt to parse version - \s* \) # closing parenthesis - )? # end of optional part - (?: # start of optional architecture - \s* \[ # open bracket for architecture - \s* ([^\]]+) # don't parse architectures now - \s* \] # closing bracket - )? # end of optional architecture - ( - (?: # start of optional restriction - \s* < # open bracket for restriction - \s* [^>]+ # do not parse restrictions now - \s* > # closing bracket - )+ - )? # end of optional restriction - \s*$ # trailing spaces at end - }x; - if (defined($2)) { - return if $2 eq 'native' and not $self->{build_dep}; - $self->{archqual} = $2; - } - $self->{package} = $1; - $self->{relation} = version_normalize_relation($3) if defined($3); - if (defined($4)) { - $self->{version} = Dpkg::Version->new($4); - } - if (defined($5)) { - $self->{arches} = [ debarch_list_parse($5) ]; - } - if (defined($6)) { - $self->{restrictions} = [ parse_build_profiles($6) ]; - } -} - -sub output { - my ($self, $fh) = @_; - my $res = $self->{package}; - if (defined($self->{archqual})) { - $res .= ':' . $self->{archqual}; - } - if (defined($self->{relation})) { - $res .= ' (' . $self->{relation} . ' ' . $self->{version} . ')'; - } - if (defined($self->{arches})) { - $res .= ' [' . join(' ', @{$self->{arches}}) . ']'; - } - if (defined($self->{restrictions})) { - for my $restrlist (@{$self->{restrictions}}) { - $res .= ' <' . join(' ', @{$restrlist}) . '>'; - } - } - if (defined($fh)) { - print { $fh } $res; - } - return $res; -} - -# _arch_is_superset(\@p, \@q) -# -# Returns true if the arch list @p is a superset of arch list @q. -# The arguments can also be undef in case there's no explicit architecture -# restriction. -sub _arch_is_superset { - my ($p, $q) = @_; - my $p_arch_neg = defined($p) && $p->[0] =~ /^!/; - my $q_arch_neg = defined($q) && $q->[0] =~ /^!/; - - # If "p" has no arches, it is a superset of q and we should fall through - # to the version check. - if (not defined $p) { - return 1; - } - - # If q has no arches, it is a superset of p and there are no useful - # implications. - elsif (not defined $q) { - return 0; - } - - # Both have arches. If neither are negated, we know nothing useful - # unless q is a subset of p. - elsif (not $p_arch_neg and not $q_arch_neg) { - my %p_arches = map { $_ => 1 } @{$p}; - my $subset = 1; - for my $arch (@{$q}) { - $subset = 0 unless $p_arches{$arch}; - } - return 0 unless $subset; - } - - # If both are negated, we know nothing useful unless p is a subset of - # q (and therefore has fewer things excluded, and therefore is more - # general). - elsif ($p_arch_neg and $q_arch_neg) { - my %q_arches = map { $_ => 1 } @{$q}; - my $subset = 1; - for my $arch (@{$p}) { - $subset = 0 unless $q_arches{$arch}; - } - return 0 unless $subset; - } - - # If q is negated and p isn't, we'd need to know the full list of - # arches to know if there's any relationship, so bail. - elsif (not $p_arch_neg and $q_arch_neg) { - return 0; - } - - # If p is negated and q isn't, q is a subset of p if none of the - # negated arches in p are present in q. - elsif ($p_arch_neg and not $q_arch_neg) { - my %q_arches = map { $_ => 1 } @{$q}; - my $subset = 1; - for my $arch (@{$p}) { - $subset = 0 if $q_arches{substr($arch, 1)}; - } - return 0 unless $subset; - } - return 1; -} - -# _arch_qualifier_implies($p, $q) -# -# Returns true if the arch qualifier $p and $q are compatible with the -# implication $p -> $q, false otherwise. $p/$q can be undef/"any"/"native" -# or an architecture string. -# -# Because we are handling dependencies in isolation, and the full context -# of the implications are only known when doing dependency resolution at -# run-time, we can only assert that they are implied if they are equal. -sub _arch_qualifier_implies { - my ($p, $q) = @_; - - return $p eq $q if defined $p and defined $q; - return 1 if not defined $p and not defined $q; - return 0; -} - -# _restrictions_imply($p, $q) -# -# Returns true if the restrictions $p and $q are compatible with the -# implication $p -> $q, false otherwise. -# NOTE: We don't try to be very clever here, so we may conservatively -# return false when there is an implication. -sub _restrictions_imply { - my ($p, $q) = @_; - - if (not defined $p) { - return 1; - } elsif (not defined $q) { - return 0; - } else { - # Check whether set difference is empty. - my %restr; - - for my $restrlist (@{$q}) { - my $reststr = join ' ', sort @{$restrlist}; - $restr{$reststr} = 1; - } - for my $restrlist (@{$p}) { - my $reststr = join ' ', sort @{$restrlist}; - delete $restr{$reststr}; - } - - return keys %restr == 0; - } -} - -# Returns true if the dependency in parameter can deduced from the current -# dependency. Returns false if it can be negated. Returns undef if nothing -# can be concluded. -sub implies { - my ($self, $o) = @_; - if ($o->isa('Dpkg::Deps::Simple')) { - # An implication is only possible on the same package - return if $self->{package} ne $o->{package}; - - # Our architecture set must be a superset of the architectures for - # o, otherwise we can't conclude anything. - return unless _arch_is_superset($self->{arches}, $o->{arches}); - - # The arch qualifier must not forbid an implication - return unless _arch_qualifier_implies($self->{archqual}, - $o->{archqual}); - - # Our restrictions must imply the restrictions for o - return unless _restrictions_imply($self->{restrictions}, - $o->{restrictions}); - - # If o has no version clause, then our dependency is stronger - return 1 if not defined $o->{relation}; - # If o has a version clause, we must also have one, otherwise there - # can't be an implication - return if not defined $self->{relation}; - - return Dpkg::Deps::deps_eval_implication($self->{relation}, - $self->{version}, $o->{relation}, $o->{version}); - - } elsif ($o->isa('Dpkg::Deps::AND')) { - # TRUE: Need to imply all individual elements - # FALSE: Need to NOT imply at least one individual element - my $res = 1; - foreach my $dep ($o->get_deps()) { - my $implication = $self->implies($dep); - unless (defined($implication) && $implication == 1) { - $res = $implication; - last if defined $res; - } - } - return $res; - } elsif ($o->isa('Dpkg::Deps::OR')) { - # TRUE: Need to imply at least one individual element - # FALSE: Need to not apply all individual elements - # UNDEF: The rest - my $res = undef; - foreach my $dep ($o->get_deps()) { - my $implication = $self->implies($dep); - if (defined($implication)) { - if (not defined $res) { - $res = $implication; - } else { - if ($implication) { - $res = 1; - } else { - $res = 0; - } - } - last if defined($res) && $res == 1; - } - } - return $res; - } else { - croak 'Dpkg::Deps::Simple cannot evaluate implication with a ' . - ref($o); - } -} - -sub get_deps { - my $self = shift; - return $self; -} - -sub sort { - # Nothing to sort -} - -sub arch_is_concerned { - my ($self, $host_arch) = @_; - - return 0 if not defined $self->{package}; # Empty dep - return 1 if not defined $self->{arches}; # Dep without arch spec - - return debarch_is_concerned($host_arch, @{$self->{arches}}); -} - -sub reduce_arch { - my ($self, $host_arch) = @_; - if (not $self->arch_is_concerned($host_arch)) { - $self->reset(); - } else { - $self->{arches} = undef; - } -} - -sub has_arch_restriction { - my $self = shift; - if (defined $self->{arches}) { - return $self->{package}; - } else { - return (); - } -} - -sub profile_is_concerned { - my ($self, $build_profiles) = @_; - - return 0 if not defined $self->{package}; # Empty dep - return 1 if not defined $self->{restrictions}; # Dep without restrictions - return evaluate_restriction_formula($self->{restrictions}, $build_profiles); -} - -sub reduce_profiles { - my ($self, $build_profiles) = @_; - - if (not $self->profile_is_concerned($build_profiles)) { - $self->reset(); - } else { - $self->{restrictions} = undef; - } -} - -sub get_evaluation { - my ($self, $facts) = @_; - return if not defined $self->{package}; - return $facts->_evaluate_simple_dep($self); -} - -sub simplify_deps { - my ($self, $facts) = @_; - my $eval = $self->get_evaluation($facts); - $self->reset() if defined $eval and $eval == 1; -} - -sub is_empty { - my $self = shift; - return not defined $self->{package}; -} - -sub merge_union { - my ($self, $o) = @_; - return 0 if not $o->isa('Dpkg::Deps::Simple'); - return 0 if $self->is_empty() or $o->is_empty(); - return 0 if $self->{package} ne $o->{package}; - return 0 if defined $self->{arches} or defined $o->{arches}; - - if (not defined $o->{relation} and defined $self->{relation}) { - # Union is the non-versioned dependency - $self->{relation} = undef; - $self->{version} = undef; - return 1; - } - - my $implication = $self->implies($o); - my $rev_implication = $o->implies($self); - if (defined($implication)) { - if ($implication) { - $self->{relation} = $o->{relation}; - $self->{version} = $o->{version}; - return 1; - } else { - return 0; - } - } - if (defined($rev_implication)) { - if ($rev_implication) { - # Already merged... - return 1; - } else { - return 0; - } - } - return 0; -} - -package Dpkg::Deps::Multiple; - -=head2 Dpkg::Deps::Multiple - -This is the base class for Dpkg::Deps::{AND,OR,Union}. It implements -the following methods: - -=over 4 - -=item $mul->add($dep) - -Adds a new dependency object at the end of the list. - -=back - -=cut - -use strict; -use warnings; - -use Carp; - -use Dpkg::ErrorHandling; - -use parent qw(Dpkg::Interface::Storable); - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = { list => [ @_ ] }; - bless $self, $class; - return $self; -} - -sub reset { - my $self = shift; - $self->{list} = []; -} - -sub add { - my $self = shift; - push @{$self->{list}}, @_; -} - -sub get_deps { - my $self = shift; - return grep { not $_->is_empty() } @{$self->{list}}; -} - -sub sort { - my $self = shift; - my @res = (); - @res = sort { Dpkg::Deps::deps_compare($a, $b) } @{$self->{list}}; - $self->{list} = [ @res ]; -} - -sub arch_is_concerned { - my ($self, $host_arch) = @_; - my $res = 0; - foreach my $dep (@{$self->{list}}) { - $res = 1 if $dep->arch_is_concerned($host_arch); - } - return $res; -} - -sub reduce_arch { - my ($self, $host_arch) = @_; - my @new; - foreach my $dep (@{$self->{list}}) { - $dep->reduce_arch($host_arch); - push @new, $dep if $dep->arch_is_concerned($host_arch); - } - $self->{list} = [ @new ]; -} - -sub has_arch_restriction { - my $self = shift; - my @res; - foreach my $dep (@{$self->{list}}) { - push @res, $dep->has_arch_restriction(); - } - return @res; -} - -sub profile_is_concerned { - my ($self, $build_profiles) = @_; - my $res = 0; - - foreach my $dep (@{$self->{list}}) { - $res = 1 if $dep->profile_is_concerned($build_profiles); - } - return $res; -} - -sub reduce_profiles { - my ($self, $build_profiles) = @_; - my @new; - - foreach my $dep (@{$self->{list}}) { - $dep->reduce_profiles($build_profiles); - push @new, $dep if $dep->profile_is_concerned($build_profiles); - } - $self->{list} = [ @new ]; -} - -sub is_empty { - my $self = shift; - return scalar @{$self->{list}} == 0; -} - -sub merge_union { - croak 'method merge_union() is only valid for Dpkg::Deps::Simple'; -} - -package Dpkg::Deps::AND; - -=head2 Dpkg::Deps::AND - -This object represents a list of dependencies who must be met at the same -time. - -=over 4 - -=item $and->output([$fh]) - -The output method uses ", " to join the list of sub-dependencies. - -=back - -=cut - -use strict; -use warnings; - -use parent -norequire, qw(Dpkg::Deps::Multiple); - -sub output { - my ($self, $fh) = @_; - my $res = join(', ', map { $_->output() } grep { not $_->is_empty() } $self->get_deps()); - if (defined($fh)) { - print { $fh } $res; - } - return $res; -} - -sub implies { - my ($self, $o) = @_; - # If any individual member can imply $o or NOT $o, we're fine - foreach my $dep ($self->get_deps()) { - my $implication = $dep->implies($o); - return 1 if defined($implication) && $implication == 1; - return 0 if defined($implication) && $implication == 0; - } - # If o is an AND, we might have an implication, if we find an - # implication within us for each predicate in o - if ($o->isa('Dpkg::Deps::AND')) { - my $subset = 1; - foreach my $odep ($o->get_deps()) { - my $found = 0; - foreach my $dep ($self->get_deps()) { - $found = 1 if $dep->implies($odep); - } - $subset = 0 if not $found; - } - return 1 if $subset; - } - return; -} - -sub get_evaluation { - my ($self, $facts) = @_; - # Return 1 only if all members evaluates to true - # Return 0 if at least one member evaluates to false - # Return undef otherwise - my $result = 1; - foreach my $dep ($self->get_deps()) { - my $eval = $dep->get_evaluation($facts); - if (not defined $eval) { - $result = undef; - } elsif ($eval == 0) { - $result = 0; - last; - } elsif ($eval == 1) { - # Still possible - } - } - return $result; -} - -sub simplify_deps { - my ($self, $facts, @knowndeps) = @_; - my @new; - -WHILELOOP: - while (@{$self->{list}}) { - my $dep = shift @{$self->{list}}; - my $eval = $dep->get_evaluation($facts); - next if defined($eval) and $eval == 1; - foreach my $odep (@knowndeps, @new) { - next WHILELOOP if $odep->implies($dep); - } - # When a dependency is implied by another dependency that - # follows, then invert them - # "a | b, c, a" becomes "a, c" and not "c, a" - my $i = 0; - foreach my $odep (@{$self->{list}}) { - if (defined $odep and $odep->implies($dep)) { - splice @{$self->{list}}, $i, 1; - unshift @{$self->{list}}, $odep; - next WHILELOOP; - } - $i++; - } - push @new, $dep; - } - $self->{list} = [ @new ]; -} - - -package Dpkg::Deps::OR; - -=head2 Dpkg::Deps::OR - -This object represents a list of dependencies of which only one must be met -for the dependency to be true. - -=over 4 - -=item $or->output([$fh]) - -The output method uses " | " to join the list of sub-dependencies. - -=back - -=cut - -use strict; -use warnings; - -use parent -norequire, qw(Dpkg::Deps::Multiple); - -sub output { - my ($self, $fh) = @_; - my $res = join(' | ', map { $_->output() } grep { not $_->is_empty() } $self->get_deps()); - if (defined($fh)) { - print { $fh } $res; - } - return $res; -} - -sub implies { - my ($self, $o) = @_; - - # Special case for AND with a single member, replace it by its member - if ($o->isa('Dpkg::Deps::AND')) { - my @subdeps = $o->get_deps(); - if (scalar(@subdeps) == 1) { - $o = $subdeps[0]; - } - } - - # In general, an OR dependency can't imply anything except if each - # of its member implies a member in the other OR dependency - if ($o->isa('Dpkg::Deps::OR')) { - my $subset = 1; - foreach my $dep ($self->get_deps()) { - my $found = 0; - foreach my $odep ($o->get_deps()) { - $found = 1 if $dep->implies($odep); - } - $subset = 0 if not $found; - } - return 1 if $subset; - } - return; -} - -sub get_evaluation { - my ($self, $facts) = @_; - # Returns false if all members evaluates to 0 - # Returns true if at least one member evaluates to true - # Returns undef otherwise - my $result = 0; - foreach my $dep ($self->get_deps()) { - my $eval = $dep->get_evaluation($facts); - if (not defined $eval) { - $result = undef; - } elsif ($eval == 1) { - $result = 1; - last; - } elsif ($eval == 0) { - # Still possible to have a false evaluation - } - } - return $result; -} - -sub simplify_deps { - my ($self, $facts) = @_; - my @new; - -WHILELOOP: - while (@{$self->{list}}) { - my $dep = shift @{$self->{list}}; - my $eval = $dep->get_evaluation($facts); - if (defined($eval) and $eval == 1) { - $self->{list} = []; - return; - } - foreach my $odep (@new, @{$self->{list}}) { - next WHILELOOP if $odep->implies($dep); - } - push @new, $dep; - } - $self->{list} = [ @new ]; -} - -package Dpkg::Deps::Union; - -=head2 Dpkg::Deps::Union - -This object represents a list of relationships. - -=over 4 - -=item $union->output([$fh]) - -The output method uses ", " to join the list of relationships. - -=item $union->implies($other_dep) - -=item $union->get_evaluation($other_dep) - -Those methods are not meaningful for this object and always return undef. - -=item $union->simplify_deps($facts) - -The simplification is done to generate an union of all the relationships. -It uses $simple_dep->merge_union($other_dep) to get its job done. - -=back - -=cut - -use strict; -use warnings; - -use parent -norequire, qw(Dpkg::Deps::Multiple); - -sub output { - my ($self, $fh) = @_; - my $res = join(', ', map { $_->output() } grep { not $_->is_empty() } $self->get_deps()); - if (defined($fh)) { - print { $fh } $res; - } - return $res; -} - -sub implies { - # Implication test are not useful on Union - return; -} - -sub get_evaluation { - # Evaluation are not useful on Union - return; -} - -sub simplify_deps { - my ($self, $facts) = @_; - my @new; - -WHILELOOP: - while (@{$self->{list}}) { - my $odep = shift @{$self->{list}}; - foreach my $dep (@new) { - next WHILELOOP if $dep->merge_union($odep); - } - push @new, $odep; - } - $self->{list} = [ @new ]; -} - -package Dpkg::Deps::KnownFacts; - -=head2 Dpkg::Deps::KnownFacts - -This object represents a list of installed packages and a list of virtual -packages provided (by the set of installed packages). - -=over 4 - -=item $facts = Dpkg::Deps::KnownFacts->new(); - -Creates a new object. - -=cut - -use strict; -use warnings; - -use Dpkg::Version; - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = { - pkg => {}, - virtualpkg => {}, - }; - bless $self, $class; - return $self; -} - -=item $facts->add_installed_package($package, $version, $arch, $multiarch) - -Records that the given version of the package is installed. If -$version/$arch is undefined we know that the package is installed but we -don't know which version/architecture it is. $multiarch is the Multi-Arch -field of the package. If $multiarch is undef, it will be equivalent to -"Multi-Arch: no". - -Note that $multiarch is only used if $arch is provided. - -=cut - -sub add_installed_package { - my ($self, $pkg, $ver, $arch, $multiarch) = @_; - my $p = { - package => $pkg, - version => $ver, - architecture => $arch, - multiarch => $multiarch // 'no', - }; - $self->{pkg}{"$pkg:$arch"} = $p if defined $arch; - push @{$self->{pkg}{$pkg}}, $p; -} - -=item $facts->add_provided_package($virtual, $relation, $version, $by) - -Records that the "$by" package provides the $virtual package. $relation -and $version correspond to the associated relation given in the Provides -field (if present). - -=cut - -sub add_provided_package { - my ($self, $pkg, $rel, $ver, $by) = @_; - - $self->{virtualpkg}{$pkg} //= []; - push @{$self->{virtualpkg}{$pkg}}, [ $by, $rel, $ver ]; -} - -=item ($check, $param) = $facts->check_package($package) - -$check is one when the package is found. For a real package, $param -contains the version. For a virtual package, $param contains an array -reference containing the list of packages that provide it (each package is -listed as [ $provider, $relation, $version ]). - -This function is obsolete and should not be used. Dpkg::Deps::KnownFacts -is only meant to be filled with data and then passed to Dpkg::Deps -methods where appropriate, but it should not be directly queried. - -=back - -=cut - -sub check_package { - my ($self, $pkg) = @_; - - warnings::warnif('deprecated', 'obsolete function, pass ' . - 'Dpkg::Deps::KnownFacts to Dpkg::Deps methods instead'); - - if (exists $self->{pkg}{$pkg}) { - return (1, $self->{pkg}{$pkg}[0]{version}); - } - if (exists $self->{virtualpkg}{$pkg}) { - return (1, $self->{virtualpkg}{$pkg}); - } - return (0, undef); -} - -## The functions below are private to Dpkg::Deps - -sub _find_package { - my ($self, $dep, $lackinfos) = @_; - my ($pkg, $archqual) = ($dep->{package}, $dep->{archqual}); - return if not exists $self->{pkg}{$pkg}; - my $host_arch = $dep->{host_arch} // Dpkg::Arch::get_host_arch(); - my $build_arch = $dep->{build_arch} // Dpkg::Arch::get_build_arch(); - foreach my $p (@{$self->{pkg}{$pkg}}) { - my $a = $p->{architecture}; - my $ma = $p->{multiarch}; - if (not defined $a) { - $$lackinfos = 1; - next; - } - if (not defined $archqual) { - return $p if $ma eq 'foreign'; - return $p if $a eq $host_arch or $a eq 'all'; - } elsif ($archqual eq 'any') { - return $p if $ma eq 'allowed'; - } elsif ($archqual eq 'native') { - return $p if $a eq $build_arch and $ma ne 'foreign'; - } else { - return $p if $a eq $archqual; - } - } - return; -} - -sub _find_virtual_packages { - my ($self, $pkg) = @_; - return () if not exists $self->{virtualpkg}{$pkg}; - return @{$self->{virtualpkg}{$pkg}}; -} +=head1 CHANGES -sub _evaluate_simple_dep { - my ($self, $dep) = @_; - my ($lackinfos, $pkg) = (0, $dep->{package}); - my $p = $self->_find_package($dep, \$lackinfos); - if ($p) { - if (defined $dep->{relation}) { - if (defined $p->{version}) { - return 1 if version_compare_relation($p->{version}, - $dep->{relation}, $dep->{version}); - } else { - $lackinfos = 1; - } - } else { - return 1; - } - } - foreach my $virtpkg ($self->_find_virtual_packages($pkg)) { - next if defined $virtpkg->[1] and $virtpkg->[1] ne REL_EQ; - - if (defined $dep->{relation}) { - next if not defined $virtpkg->[2]; - return 1 if version_compare_relation($virtpkg->[2], - $dep->{relation}, - $dep->{version}); - } else { - return 1; - } - } - return if $lackinfos; - return 0; -} +=head2 Version 1.07 (dpkg 1.20.0) -=head1 CHANGES +New option: Add virtual option to Dpkg::Deps::deps_parse(). =head2 Version 1.06 (dpkg 1.18.7; module version bumped on dpkg 1.18.24) @@ -1540,9 +467,6 @@ New function: Dpkg::Deps::deps_iterate(). New options: Add use_profiles, build_profiles, reduce_profiles and reduce_restrictions to Dpkg::Deps::deps_parse(). -New methods: Add $dep->profile_is_concerned() and $dep->reduce_profiles() -for all dependency objects. - =head2 Version 1.03 (dpkg 1.17.0) New option: Add build_arch option to Dpkg::Deps::deps_parse(). @@ -1553,16 +477,7 @@ New function: Dpkg::Deps::deps_concat() =head2 Version 1.01 (dpkg 1.16.1) -New method: Add $dep->reset() for all dependency objects. - -New property: Dpkg::Deps::Simple now recognizes the arch qualifier "any" -and stores it in the "archqual" property when present. - -New option: Dpkg::Deps::KnownFacts->add_installed_package() now accepts 2 -supplementary parameters ($arch and $multiarch). - -Deprecated method: Dpkg::Deps::KnownFacts->check_package() is obsolete, -it should not have been part of the public API. +<Used to document changes to Dpkg::Deps::* modules before they were split.> =head2 Version 1.00 (dpkg 1.15.6) diff --git a/scripts/Dpkg/Deps/AND.pm b/scripts/Dpkg/Deps/AND.pm new file mode 100644 index 000000000..7b403c237 --- /dev/null +++ b/scripts/Dpkg/Deps/AND.pm @@ -0,0 +1,182 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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::Deps::AND; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::AND - list of AND dependencies + +=head1 DESCRIPTION + +This class represents a list of dependencies that must be met at the same +time. It inherits from Dpkg::Deps::Multiple. + +=cut + +use strict; +use warnings; + +our $VERSION = '1.00'; + +use parent qw(Dpkg::Deps::Multiple); + +=head1 METHODS + +=over 4 + +=item $dep->output([$fh]) + +The output method uses ", " to join the list of sub-dependencies. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = join(', ', map { + $_->output() + } grep { + not $_->is_empty() + } $self->get_deps()); + + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +=item $dep->implies($other_dep) + +Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies +NOT($other_dep). Returns undef when there's no implication. $dep and +$other_dep do not need to be of the same type. + +=cut + +sub implies { + my ($self, $o) = @_; + + # If any individual member can imply $o or NOT $o, we're fine + foreach my $dep ($self->get_deps()) { + my $implication = $dep->implies($o); + return 1 if defined $implication and $implication == 1; + return 0 if defined $implication and $implication == 0; + } + + # If o is an AND, we might have an implication, if we find an + # implication within us for each predicate in o + if ($o->isa('Dpkg::Deps::AND')) { + my $subset = 1; + foreach my $odep ($o->get_deps()) { + my $found = 0; + foreach my $dep ($self->get_deps()) { + $found = 1 if $dep->implies($odep); + } + $subset = 0 if not $found; + } + return 1 if $subset; + } + return; +} + +=item $dep->get_evaluation($facts) + +Evaluates the dependency given a list of installed packages and a list of +virtual packages provided. These lists are part of the Dpkg::Deps::KnownFacts +object given as parameters. + +Returns 1 when it's true, 0 when it's false, undef when some information +is lacking to conclude. + +=cut + +sub get_evaluation { + my ($self, $facts) = @_; + + # Return 1 only if all members evaluates to true + # Return 0 if at least one member evaluates to false + # Return undef otherwise + my $result = 1; + foreach my $dep ($self->get_deps()) { + my $eval = $dep->get_evaluation($facts); + if (not defined $eval) { + $result = undef; + } elsif ($eval == 0) { + $result = 0; + last; + } elsif ($eval == 1) { + # Still possible + } + } + return $result; +} + +=item $dep->simplify_deps($facts, @assumed_deps) + +Simplifies the dependency as much as possible given the list of facts (see +object Dpkg::Deps::KnownFacts) and a list of other dependencies that are +known to be true. + +=cut + +sub simplify_deps { + my ($self, $facts, @knowndeps) = @_; + my @new; + +WHILELOOP: + while (@{$self->{list}}) { + my $dep = shift @{$self->{list}}; + my $eval = $dep->get_evaluation($facts); + next if defined $eval and $eval == 1; + foreach my $odep (@knowndeps, @new) { + next WHILELOOP if $odep->implies($dep); + } + # When a dependency is implied by another dependency that + # follows, then invert them + # "a | b, c, a" becomes "a, c" and not "c, a" + my $i = 0; + foreach my $odep (@{$self->{list}}) { + if (defined $odep and $odep->implies($dep)) { + splice @{$self->{list}}, $i, 1; + unshift @{$self->{list}}, $odep; + next WHILELOOP; + } + $i++; + } + push @new, $dep; + } + $self->{list} = [ @new ]; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/KnownFacts.pm b/scripts/Dpkg/Deps/KnownFacts.pm new file mode 100644 index 000000000..ef8655fdd --- /dev/null +++ b/scripts/Dpkg/Deps/KnownFacts.pm @@ -0,0 +1,218 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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::Deps::KnownFacts; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::KnownFacts - list of installed real and virtual packages + +=head1 DESCRIPTION + +This class represents a list of installed packages and a list of virtual +packages provided (by the set of installed packages). + +=cut + +use strict; +use warnings; + +our $VERSION = '2.00'; + +use Dpkg::Version; + +=head1 METHODS + +=over 4 + +=item $facts = Dpkg::Deps::KnownFacts->new(); + +Creates a new object. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = { + pkg => {}, + virtualpkg => {}, + }; + + bless $self, $class; + return $self; +} + +=item $facts->add_installed_package($package, $version, $arch, $multiarch) + +Records that the given version of the package is installed. If +$version/$arch is undefined we know that the package is installed but we +don't know which version/architecture it is. $multiarch is the Multi-Arch +field of the package. If $multiarch is undef, it will be equivalent to +"Multi-Arch: no". + +Note that $multiarch is only used if $arch is provided. + +=cut + +sub add_installed_package { + my ($self, $pkg, $ver, $arch, $multiarch) = @_; + my $p = { + package => $pkg, + version => $ver, + architecture => $arch, + multiarch => $multiarch // 'no', + }; + + $self->{pkg}{"$pkg:$arch"} = $p if defined $arch; + push @{$self->{pkg}{$pkg}}, $p; +} + +=item $facts->add_provided_package($virtual, $relation, $version, $by) + +Records that the "$by" package provides the $virtual package. $relation +and $version correspond to the associated relation given in the Provides +field (if present). + +=cut + +sub add_provided_package { + my ($self, $pkg, $rel, $ver, $by) = @_; + my $v = { + package => $pkg, + relation => $rel, + version => $ver, + provider => $by, + }; + + $self->{virtualpkg}{$pkg} //= []; + push @{$self->{virtualpkg}{$pkg}}, $v; +} + +## +## The functions below are private to Dpkg::Deps::KnownFacts. +## + +sub _find_package { + my ($self, $dep, $lackinfos) = @_; + my ($pkg, $archqual) = ($dep->{package}, $dep->{archqual}); + + return if not exists $self->{pkg}{$pkg}; + + my $host_arch = $dep->{host_arch} // Dpkg::Arch::get_host_arch(); + my $build_arch = $dep->{build_arch} // Dpkg::Arch::get_build_arch(); + + foreach my $p (@{$self->{pkg}{$pkg}}) { + my $a = $p->{architecture}; + my $ma = $p->{multiarch}; + + if (not defined $a) { + $$lackinfos = 1; + next; + } + if (not defined $archqual) { + return $p if $ma eq 'foreign'; + return $p if $a eq $host_arch or $a eq 'all'; + } elsif ($archqual eq 'any') { + return $p if $ma eq 'allowed'; + } elsif ($archqual eq 'native') { + return if $ma eq 'foreign'; + return $p if $a eq $build_arch or $a eq 'all'; + } else { + return $p if $a eq $archqual; + } + } + return; +} + +sub _find_virtual_packages { + my ($self, $pkg) = @_; + + return () if not exists $self->{virtualpkg}{$pkg}; + return @{$self->{virtualpkg}{$pkg}}; +} + +=item $facts->evaluate_simple_dep() + +This method is private and should not be used except from within Dpkg::Deps. + +=cut + +sub evaluate_simple_dep { + my ($self, $dep) = @_; + my ($lackinfos, $pkg) = (0, $dep->{package}); + + my $p = $self->_find_package($dep, \$lackinfos); + if ($p) { + if (defined $dep->{relation}) { + if (defined $p->{version}) { + return 1 if version_compare_relation($p->{version}, + $dep->{relation}, + $dep->{version}); + } else { + $lackinfos = 1; + } + } else { + return 1; + } + } + foreach my $virtpkg ($self->_find_virtual_packages($pkg)) { + next if defined $virtpkg->{relation} and + $virtpkg->{relation} ne REL_EQ; + + if (defined $dep->{relation}) { + next if not defined $virtpkg->{version}; + return 1 if version_compare_relation($virtpkg->{version}, + $dep->{relation}, + $dep->{version}); + } else { + return 1; + } + } + return if $lackinfos; + return 0; +} + +=back + +=head1 CHANGES + +=head2 Version 2.00 (dpkg 1.20.0) + +Remove method: $facts->check_package(). + +=head2 Version 1.01 (dpkg 1.16.1) + +New option: Dpkg::Deps::KnownFacts->add_installed_package() now accepts 2 +supplementary parameters ($arch and $multiarch). + +Deprecated method: Dpkg::Deps::KnownFacts->check_package() is obsolete, +it should not have been part of the public API. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/Multiple.pm b/scripts/Dpkg/Deps/Multiple.pm new file mode 100644 index 000000000..da12f5184 --- /dev/null +++ b/scripts/Dpkg/Deps/Multiple.pm @@ -0,0 +1,250 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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::Deps::Multiple; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::Multiple - base module to represent multiple dependencies + +=head1 DESCRIPTION + +The Dpkg::Deps::Multiple module provides objects implementing various types +of dependencies. It is the base class for Dpkg::Deps::{AND,OR,Union}. + +=cut + +use strict; +use warnings; + +our $VERSION = '1.02'; + +use Carp; + +use Dpkg::ErrorHandling; + +use parent qw(Dpkg::Interface::Storable); + +=head1 METHODS + +=over 4 + +=item $dep = Dpkg::Deps::Multiple->new(%opts); + +Creates a new object. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = { list => [ @_ ] }; + + bless $self, $class; + return $self; +} + +=item $dep->reset() + +Clears any dependency information stored in $dep so that $dep->is_empty() +returns true. + +=cut + +sub reset { + my $self = shift; + + $self->{list} = []; +} + +=item $dep->add(@deps) + +Adds new dependency objects at the end of the list. + +=cut + +sub add { + my $self = shift; + + push @{$self->{list}}, @_; +} + +=item $dep->get_deps() + +Returns a list of sub-dependencies. + +=cut + +sub get_deps { + my $self = shift; + + return grep { not $_->is_empty() } @{$self->{list}}; +} + +=item $dep->sort() + +Sorts alphabetically the internal list of dependencies. + +=cut + +sub sort { + my $self = shift; + + my @res = (); + @res = sort { Dpkg::Deps::deps_compare($a, $b) } @{$self->{list}}; + $self->{list} = [ @res ]; +} + +=item $dep->arch_is_concerned($arch) + +Returns true if at least one of the sub-dependencies apply to this +architecture. + +=cut + +sub arch_is_concerned { + my ($self, $host_arch) = @_; + + my $res = 0; + foreach my $dep (@{$self->{list}}) { + $res = 1 if $dep->arch_is_concerned($host_arch); + } + return $res; +} + +=item $dep->reduce_arch($arch) + +Simplifies the dependencies to contain only information relevant to the +given architecture. The non-relevant sub-dependencies are simply removed. + +This trims off the architecture restriction list of Dpkg::Deps::Simple +objects. + +=cut + +sub reduce_arch { + my ($self, $host_arch) = @_; + + my @new; + foreach my $dep (@{$self->{list}}) { + $dep->reduce_arch($host_arch); + push @new, $dep if $dep->arch_is_concerned($host_arch); + } + $self->{list} = [ @new ]; +} + +=item $dep->has_arch_restriction() + +Returns the list of package names that have such a restriction. + +=cut + +sub has_arch_restriction { + my $self = shift; + + my @res; + foreach my $dep (@{$self->{list}}) { + push @res, $dep->has_arch_restriction(); + } + return @res; +} + +=item $dep->profile_is_concerned() + +Returns true if at least one of the sub-dependencies apply to this profile. + +=cut + +sub profile_is_concerned { + my ($self, $build_profiles) = @_; + + my $res = 0; + foreach my $dep (@{$self->{list}}) { + $res = 1 if $dep->profile_is_concerned($build_profiles); + } + return $res; +} + +=item $dep->reduce_profiles() + +Simplifies the dependencies to contain only information relevant to the +given profile. The non-relevant sub-dependencies are simply removed. + +This trims off the profile restriction list of Dpkg::Deps::Simple objects. + +=cut + +sub reduce_profiles { + my ($self, $build_profiles) = @_; + + my @new; + foreach my $dep (@{$self->{list}}) { + $dep->reduce_profiles($build_profiles); + push @new, $dep if $dep->profile_is_concerned($build_profiles); + } + $self->{list} = [ @new ]; +} + +=item $dep->is_empty() + +Returns true if the dependency is empty and doesn't contain any useful +information. This is true when a (descendant of) Dpkg::Deps::Multiple +contains an empty list of dependencies. + +=cut + +sub is_empty { + my $self = shift; + + return scalar @{$self->{list}} == 0; +} + +=item $dep->merge_union($other_dep) + +This method is not meaningful for this object, and will always croak. + +=cut + +sub merge_union { + croak 'method merge_union() is only valid for Dpkg::Deps::Simple'; +} + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.17.10) + +New methods: Add $dep->profile_is_concerned() and $dep->reduce_profiles(). + +=head2 Version 1.01 (dpkg 1.16.1) + +New method: Add $dep->reset(). + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/OR.pm b/scripts/Dpkg/Deps/OR.pm new file mode 100644 index 000000000..4ce5c9818 --- /dev/null +++ b/scripts/Dpkg/Deps/OR.pm @@ -0,0 +1,174 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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::Deps::OR; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::OR - list of OR dependencies + +=head1 DESCRIPTION + +This class represents a list of dependencies of which only one must be met +for the dependency to be true. It inherits from Dpkg::Deps::Multiple. + +=cut + +use strict; +use warnings; + +our $VERSION = '1.00'; + +use parent qw(Dpkg::Deps::Multiple); + +=head1 METHODS + +=over 4 + +=item $dep->output([$fh]) + +The output method uses " | " to join the list of sub-dependencies. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = join(' | ', map { + $_->output() + } grep { + not $_->is_empty() + } $self->get_deps()); + + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +=item $dep->implies($other_dep) + +Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies +NOT($other_dep). Returns undef when there's no implication. $dep and +$other_dep do not need to be of the same type. + +=cut + +sub implies { + my ($self, $o) = @_; + + # Special case for AND with a single member, replace it by its member + if ($o->isa('Dpkg::Deps::AND')) { + my @subdeps = $o->get_deps(); + if (scalar(@subdeps) == 1) { + $o = $subdeps[0]; + } + } + + # In general, an OR dependency can't imply anything except if each + # of its member implies a member in the other OR dependency + if ($o->isa('Dpkg::Deps::OR')) { + my $subset = 1; + foreach my $dep ($self->get_deps()) { + my $found = 0; + foreach my $odep ($o->get_deps()) { + $found = 1 if $dep->implies($odep); + } + $subset = 0 if not $found; + } + return 1 if $subset; + } + return; +} + +=item $dep->get_evaluation($facts) + +Evaluates the dependency given a list of installed packages and a list of +virtual packages provided. These lists are part of the Dpkg::Deps::KnownFacts +object given as parameters. + +Returns 1 when it's true, 0 when it's false, undef when some information +is lacking to conclude. + +=cut + +sub get_evaluation { + my ($self, $facts) = @_; + + # Returns false if all members evaluates to 0 + # Returns true if at least one member evaluates to true + # Returns undef otherwise + my $result = 0; + foreach my $dep ($self->get_deps()) { + my $eval = $dep->get_evaluation($facts); + if (not defined $eval) { + $result = undef; + } elsif ($eval == 1) { + $result = 1; + last; + } elsif ($eval == 0) { + # Still possible to have a false evaluation + } + } + return $result; +} + +=item $dep->simplify_deps($facts, @assumed_deps) + +Simplifies the dependency as much as possible given the list of facts (see +object Dpkg::Deps::KnownFacts) and a list of other dependencies that are +known to be true. + +=cut + +sub simplify_deps { + my ($self, $facts) = @_; + my @new; + +WHILELOOP: + while (@{$self->{list}}) { + my $dep = shift @{$self->{list}}; + my $eval = $dep->get_evaluation($facts); + if (defined $eval and $eval == 1) { + $self->{list} = []; + return; + } + foreach my $odep (@new, @{$self->{list}}) { + next WHILELOOP if $odep->implies($dep); + } + push @new, $dep; + } + $self->{list} = [ @new ]; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/Simple.pm b/scripts/Dpkg/Deps/Simple.pm new file mode 100644 index 000000000..aa23e7da2 --- /dev/null +++ b/scripts/Dpkg/Deps/Simple.pm @@ -0,0 +1,670 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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::Deps::Simple; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::Simple - represents a single dependency statement + +=head1 DESCRIPTION + +This class represents a single dependency statement. +It has several interesting properties: + +=over 4 + +=item package + +The package name (can be undef if the dependency has not been initialized +or if the simplification of the dependency lead to its removal). + +=item relation + +The relational operator: "=", "<<", "<=", ">=" or ">>". It can be +undefined if the dependency had no version restriction. In that case the +following field is also undefined. + +=item version + +The version. + +=item arches + +The list of architectures where this dependency is applicable. It is +undefined when there's no restriction, otherwise it is an +array ref. It can contain an exclusion list, in that case each +architecture is prefixed with an exclamation mark. + +=item archqual + +The arch qualifier of the dependency (can be undef if there is none). +In the dependency "python:any (>= 2.6)", the arch qualifier is "any". + +=item restrictions + +The restrictions formula for this dependency. It is undefined when there +is no restriction formula. Otherwise it is an array ref. + +=back + +=head1 METHODS + +=over 4 + +=cut + +use strict; +use warnings; + +our $VERSION = '1.02'; + +use Carp; + +use Dpkg::Arch qw(debarch_is_concerned debarch_list_parse); +use Dpkg::BuildProfiles qw(parse_build_profiles evaluate_restriction_formula); +use Dpkg::Version; +use Dpkg::ErrorHandling; +use Dpkg::Gettext; + +use parent qw(Dpkg::Interface::Storable); + +=item $dep = Dpkg::Deps::Simple->new([$dep[, %opts]]); + +Creates a new object. Some options can be set through %opts: + +=over + +=item host_arch + +Sets the host architecture. + +=item build_arch + +Sets the build architecture. + +=item build_dep + +Specifies whether the parser should consider it a build dependency. +Defaults to 0. + +=item tests_dep + +Specifies whether the parser should consider it a tests dependency. +Defaults to 0. + +=back + +=cut + +sub new { + my ($this, $arg, %opts) = @_; + my $class = ref($this) || $this; + my $self = {}; + + bless $self, $class; + $self->reset(); + $self->{host_arch} = $opts{host_arch}; + $self->{build_arch} = $opts{build_arch}; + $self->{build_dep} = $opts{build_dep} // 0; + $self->{tests_dep} = $opts{tests_dep} // 0; + $self->parse_string($arg) if defined $arg; + return $self; +} + +=item $dep->reset() + +Clears any dependency information stored in $dep so that $dep->is_empty() +returns true. + +=cut + +sub reset { + my $self = shift; + + $self->{package} = undef; + $self->{relation} = undef; + $self->{version} = undef; + $self->{arches} = undef; + $self->{archqual} = undef; + $self->{restrictions} = undef; +} + +=item $dep->parse_string($dep_string) + +Parses the dependency string and modifies internal properties to match the +parsed dependency. + +=cut + +sub parse_string { + my ($self, $dep) = @_; + + my $pkgname_re; + if ($self->{tests_dep}) { + $pkgname_re = qr/[\@a-zA-Z0-9][\@a-zA-Z0-9+.-]*/; + } else { + $pkgname_re = qr/[a-zA-Z0-9][a-zA-Z0-9+.-]*/; + } + + return if not $dep =~ + m{^\s* # skip leading whitespace + ($pkgname_re) # package name + (?: # start of optional part + : # colon for architecture + ([a-zA-Z0-9][a-zA-Z0-9-]*) # architecture name + )? # end of optional part + (?: # start of optional part + \s* \( # open parenthesis for version part + \s* (<<|<=|=|>=|>>|[<>]) # relation part + \s* ([^\)\s]+) # do not attempt to parse version + \s* \) # closing parenthesis + )? # end of optional part + (?: # start of optional architecture + \s* \[ # open bracket for architecture + \s* ([^\]]+) # don't parse architectures now + \s* \] # closing bracket + )? # end of optional architecture + ( + (?: # start of optional restriction + \s* < # open bracket for restriction + \s* [^>]+ # do not parse restrictions now + \s* > # closing bracket + )+ + )? # end of optional restriction + \s*$ # trailing spaces at end + }x; + if (defined $2) { + return if $2 eq 'native' and not $self->{build_dep}; + $self->{archqual} = $2; + } + $self->{package} = $1; + $self->{relation} = version_normalize_relation($3) if defined $3; + if (defined $4) { + $self->{version} = Dpkg::Version->new($4); + } + if (defined $5) { + $self->{arches} = [ debarch_list_parse($5) ]; + } + if (defined $6) { + $self->{restrictions} = [ parse_build_profiles($6) ]; + } +} + +=item $dep->parse($fh, $desc) + +Parse a dependency line from a filehandle. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + + my $line = <$fh>; + chomp $line; + return $self->parse_string($line); +} + +=item $dep->load($filename) + +Parse a dependency line from $filename. + +=item $dep->output([$fh]) + +=item "$dep" + +Returns a string representing the dependency. If $fh is set, it prints +the string to the filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = $self->{package}; + if (defined $self->{archqual}) { + $res .= ':' . $self->{archqual}; + } + if (defined $self->{relation}) { + $res .= ' (' . $self->{relation} . ' ' . $self->{version} . ')'; + } + if (defined $self->{arches}) { + $res .= ' [' . join(' ', @{$self->{arches}}) . ']'; + } + if (defined $self->{restrictions}) { + for my $restrlist (@{$self->{restrictions}}) { + $res .= ' <' . join(' ', @{$restrlist}) . '>'; + } + } + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +=item $dep->save($filename) + +Save the dependency into the given $filename. + +=cut + +# _arch_is_superset(\@p, \@q) +# +# Returns true if the arch list @p is a superset of arch list @q. +# The arguments can also be undef in case there's no explicit architecture +# restriction. +sub _arch_is_superset { + my ($p, $q) = @_; + my $p_arch_neg = defined $p and $p->[0] =~ /^!/; + my $q_arch_neg = defined $q and $q->[0] =~ /^!/; + + # If "p" has no arches, it is a superset of q and we should fall through + # to the version check. + if (not defined $p) { + return 1; + } + # If q has no arches, it is a superset of p and there are no useful + # implications. + elsif (not defined $q) { + return 0; + } + # Both have arches. If neither are negated, we know nothing useful + # unless q is a subset of p. + elsif (not $p_arch_neg and not $q_arch_neg) { + my %p_arches = map { $_ => 1 } @{$p}; + my $subset = 1; + for my $arch (@{$q}) { + $subset = 0 unless $p_arches{$arch}; + } + return 0 unless $subset; + } + # If both are negated, we know nothing useful unless p is a subset of + # q (and therefore has fewer things excluded, and therefore is more + # general). + elsif ($p_arch_neg and $q_arch_neg) { + my %q_arches = map { $_ => 1 } @{$q}; + my $subset = 1; + for my $arch (@{$p}) { + $subset = 0 unless $q_arches{$arch}; + } + return 0 unless $subset; + } + # If q is negated and p isn't, we'd need to know the full list of + # arches to know if there's any relationship, so bail. + elsif (not $p_arch_neg and $q_arch_neg) { + return 0; + } + # If p is negated and q isn't, q is a subset of p if none of the + # negated arches in p are present in q. + elsif ($p_arch_neg and not $q_arch_neg) { + my %q_arches = map { $_ => 1 } @{$q}; + my $subset = 1; + for my $arch (@{$p}) { + $subset = 0 if $q_arches{substr($arch, 1)}; + } + return 0 unless $subset; + } + return 1; +} + +# _arch_qualifier_implies($p, $q) +# +# Returns true if the arch qualifier $p and $q are compatible with the +# implication $p -> $q, false otherwise. $p/$q can be undef/"any"/"native" +# or an architecture string. +# +# Because we are handling dependencies in isolation, and the full context +# of the implications are only known when doing dependency resolution at +# run-time, we can only assert that they are implied if they are equal. +# +# For example dependencies with different arch-qualifiers cannot be simplified +# as these depend on the state of Multi-Arch field in the package depended on. +sub _arch_qualifier_implies { + my ($p, $q) = @_; + + return $p eq $q if defined $p and defined $q; + return 1 if not defined $p and not defined $q; + return 0; +} + +# _restrictions_imply($p, $q) +# +# Returns true if the restrictions $p and $q are compatible with the +# implication $p -> $q, false otherwise. +# NOTE: We don't try to be very clever here, so we may conservatively +# return false when there is an implication. +sub _restrictions_imply { + my ($p, $q) = @_; + + if (not defined $p) { + return 1; + } elsif (not defined $q) { + return 0; + } else { + # Check whether set difference is empty. + my %restr; + + for my $restrlist (@{$q}) { + my $reststr = join ' ', sort @{$restrlist}; + $restr{$reststr} = 1; + } + for my $restrlist (@{$p}) { + my $reststr = join ' ', sort @{$restrlist}; + delete $restr{$reststr}; + } + + return keys %restr == 0; + } +} + +=item $dep->implies($other_dep) + +Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies +NOT($other_dep). Returns undef when there is no implication. $dep and +$other_dep do not need to be of the same type. + +=cut + +sub implies { + my ($self, $o) = @_; + + if ($o->isa('Dpkg::Deps::Simple')) { + # An implication is only possible on the same package + return if $self->{package} ne $o->{package}; + + # Our architecture set must be a superset of the architectures for + # o, otherwise we can't conclude anything. + return unless _arch_is_superset($self->{arches}, $o->{arches}); + + # The arch qualifier must not forbid an implication + return unless _arch_qualifier_implies($self->{archqual}, + $o->{archqual}); + + # Our restrictions must imply the restrictions for o + return unless _restrictions_imply($self->{restrictions}, + $o->{restrictions}); + + # If o has no version clause, then our dependency is stronger + return 1 if not defined $o->{relation}; + # If o has a version clause, we must also have one, otherwise there + # can't be an implication + return if not defined $self->{relation}; + + return Dpkg::Deps::deps_eval_implication($self->{relation}, + $self->{version}, $o->{relation}, $o->{version}); + } elsif ($o->isa('Dpkg::Deps::AND')) { + # TRUE: Need to imply all individual elements + # FALSE: Need to NOT imply at least one individual element + my $res = 1; + foreach my $dep ($o->get_deps()) { + my $implication = $self->implies($dep); + unless (defined $implication and $implication == 1) { + $res = $implication; + last if defined $res; + } + } + return $res; + } elsif ($o->isa('Dpkg::Deps::OR')) { + # TRUE: Need to imply at least one individual element + # FALSE: Need to not apply all individual elements + # UNDEF: The rest + my $res = undef; + foreach my $dep ($o->get_deps()) { + my $implication = $self->implies($dep); + if (defined $implication) { + if (not defined $res) { + $res = $implication; + } else { + if ($implication) { + $res = 1; + } else { + $res = 0; + } + } + last if defined $res and $res == 1; + } + } + return $res; + } else { + croak 'Dpkg::Deps::Simple cannot evaluate implication with a ' . + ref($o); + } +} + +=item $dep->get_deps() + +Returns a list of sub-dependencies, which for this object it means it +returns itself. + +=cut + +sub get_deps { + my $self = shift; + + return $self; +} + +=item $dep->sort() + +This method is a no-op for this object. + +=cut + +sub sort { + # Nothing to sort +} + +=item $dep->arch_is_concerned($arch) + +Returns true if the dependency applies to the indicated architecture. + +=cut + +sub arch_is_concerned { + my ($self, $host_arch) = @_; + + return 0 if not defined $self->{package}; # Empty dep + return 1 if not defined $self->{arches}; # Dep without arch spec + + return debarch_is_concerned($host_arch, @{$self->{arches}}); +} + +=item $dep->reduce_arch($arch) + +Simplifies the dependency to contain only information relevant to the given +architecture. This object can be left empty after this operation. This trims +off the architecture restriction list of these objects. + +=cut + +sub reduce_arch { + my ($self, $host_arch) = @_; + + if (not $self->arch_is_concerned($host_arch)) { + $self->reset(); + } else { + $self->{arches} = undef; + } +} + +=item $dep->has_arch_restriction() + +Returns the package name if the dependency applies only to a subset of +architectures. + +=cut + +sub has_arch_restriction { + my $self = shift; + + if (defined $self->{arches}) { + return $self->{package}; + } else { + return (); + } +} + +=item $dep->profile_is_concerned() + +Returns true if the dependency applies to the indicated profile. + +=cut + +sub profile_is_concerned { + my ($self, $build_profiles) = @_; + + return 0 if not defined $self->{package}; # Empty dep + return 1 if not defined $self->{restrictions}; # Dep without restrictions + return evaluate_restriction_formula($self->{restrictions}, $build_profiles); +} + +=item $dep->reduce_profiles() + +Simplifies the dependency to contain only information relevant to the given +profile. This object can be left empty after this operation. This trims off +the profile restriction list of this object. + +=cut + +sub reduce_profiles { + my ($self, $build_profiles) = @_; + + if (not $self->profile_is_concerned($build_profiles)) { + $self->reset(); + } else { + $self->{restrictions} = undef; + } +} + +=item $dep->get_evaluation($facts) + +Evaluates the dependency given a list of installed packages and a list of +virtual packages provided. These lists are part of the Dpkg::Deps::KnownFacts +object given as parameters. + +Returns 1 when it's true, 0 when it's false, undef when some information +is lacking to conclude. + +=cut + +sub get_evaluation { + my ($self, $facts) = @_; + + return if not defined $self->{package}; + return $facts->evaluate_simple_dep($self); +} + +=item $dep->simplify_deps($facts, @assumed_deps) + +Simplifies the dependency as much as possible given the list of facts (see +class Dpkg::Deps::KnownFacts) and a list of other dependencies that are +known to be true. + +=cut + +sub simplify_deps { + my ($self, $facts) = @_; + + my $eval = $self->get_evaluation($facts); + $self->reset() if defined $eval and $eval == 1; +} + +=item $dep->is_empty() + +Returns true if the dependency is empty and doesn't contain any useful +information. This is true when the object has not yet been initialized. + +=cut + +sub is_empty { + my $self = shift; + + return not defined $self->{package}; +} + +=item $dep->merge_union($other_dep) + +Returns true if $dep could be modified to represent the union of both +dependencies. Otherwise returns false. + +=cut + +sub merge_union { + my ($self, $o) = @_; + + return 0 if not $o->isa('Dpkg::Deps::Simple'); + return 0 if $self->is_empty() or $o->is_empty(); + return 0 if $self->{package} ne $o->{package}; + return 0 if defined $self->{arches} or defined $o->{arches}; + + if (not defined $o->{relation} and defined $self->{relation}) { + # Union is the non-versioned dependency + $self->{relation} = undef; + $self->{version} = undef; + return 1; + } + + my $implication = $self->implies($o); + my $rev_implication = $o->implies($self); + if (defined $implication) { + if ($implication) { + $self->{relation} = $o->{relation}; + $self->{version} = $o->{version}; + return 1; + } else { + return 0; + } + } + if (defined $rev_implication) { + if ($rev_implication) { + # Already merged... + return 1; + } else { + return 0; + } + } + return 0; +} + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.17.10) + +New methods: Add $dep->profile_is_concerned() and $dep->reduce_profiles(). + +=head2 Version 1.01 (dpkg 1.16.1) + +New method: Add $dep->reset(). + +New property: recognizes the arch qualifier "any" and stores it in the +"archqual" property when present. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/Union.pm b/scripts/Dpkg/Deps/Union.pm new file mode 100644 index 000000000..148e38ed3 --- /dev/null +++ b/scripts/Dpkg/Deps/Union.pm @@ -0,0 +1,119 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <guillem@debian.org> +# +# This program is free software; you may 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 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::Deps::Union; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::Union - list of unrelated dependencies + +=head1 DESCRIPTION + +This class represents a list of relationships. +It inherits from Dpkg::Deps::Multiple. + +=cut + +use strict; +use warnings; + +our $VERSION = '1.00'; + +use parent qw(Dpkg::Deps::Multiple); + +=head1 METHODS + +=over 4 + +=item $dep->output([$fh]) + +The output method uses ", " to join the list of relationships. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = join(', ', map { + $_->output() + } grep { + not $_->is_empty() + } $self->get_deps()); + + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +=item $dep->implies($other_dep) + +=item $dep->get_evaluation($other_dep) + +These methods are not meaningful for this object and always return undef. + +=cut + +sub implies { + # Implication test is not useful on Union. + return; +} + +sub get_evaluation { + # Evaluation is not useful on Union. + return; +} + +=item $dep->simplify_deps($facts) + +The simplification is done to generate an union of all the relationships. +It uses $simple_dep->merge_union($other_dep) to get its job done. + +=cut + +sub simplify_deps { + my ($self, $facts) = @_; + my @new; + +WHILELOOP: + while (@{$self->{list}}) { + my $odep = shift @{$self->{list}}; + foreach my $dep (@new) { + next WHILELOOP if $dep->merge_union($odep); + } + push @new, $odep; + } + $self->{list} = [ @new ]; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Dist/Files.pm b/scripts/Dpkg/Dist/Files.pm index c2c426bd9..28f9d9a7a 100644 --- a/scripts/Dpkg/Dist/Files.pm +++ b/scripts/Dpkg/Dist/Files.pm @@ -81,12 +81,14 @@ sub parse { my $file; - if (m/^(\S+) (\S+) (\S+)$/) { + if (m/^(\S+) (\S+) (\S+)((?:\s+[0-9a-z-]+=\S+)*)$/) { $file = $self->parse_filename($1); error(g_('badly formed package name in files list file, line %d'), $.) unless defined $file; $file->{section} = $2; $file->{priority} = $3; + my $attrs = $4; + $file->{attrs} = { map { split /=/ } split ' ', $attrs }; } else { error(g_('badly formed line in files list file, line %d'), $.); } @@ -131,12 +133,13 @@ sub get_file { } sub add_file { - my ($self, $filename, $section, $priority) = @_; + my ($self, $filename, $section, $priority, %attrs) = @_; my $file = $self->parse_filename($filename); error(g_('invalid filename %s'), $filename) unless defined $file; $file->{section} = $section; $file->{priority} = $priority; + $file->{attrs} = \%attrs; $self->{files}->{$filename} = $file; @@ -171,7 +174,15 @@ sub output { foreach my $filename (sort keys %{$self->{files}}) { my $file = $self->{files}->{$filename}; - my $entry = "$filename $file->{section} $file->{priority}\n"; + my $entry = "$filename $file->{section} $file->{priority}"; + + if (exists $file->{attrs}) { + foreach my $attr (sort keys %{$file->{attrs}}) { + $entry .= " $attr=$file->{attrs}->{$attr}"; + } + } + + $entry .= "\n"; print { $fh } $entry if defined $fh; $str .= $entry; diff --git a/scripts/Dpkg/Exit.pm b/scripts/Dpkg/Exit.pm index 5e513b496..70a29b1a6 100644 --- a/scripts/Dpkg/Exit.pm +++ b/scripts/Dpkg/Exit.pm @@ -19,7 +19,7 @@ package Dpkg::Exit; use strict; use warnings; -our $VERSION = '1.01'; +our $VERSION = '2.00'; our @EXPORT_OK = qw( push_exit_handler pop_exit_handler @@ -28,10 +28,7 @@ our @EXPORT_OK = qw( use Exporter qw(import); -# XXX: Backwards compatibility, stop exporting on VERSION 2.00. -## no critic (Variables::ProhibitPackageVars) -our @handlers = (); -## use critic +my @handlers = (); =encoding utf8 @@ -55,6 +52,8 @@ Register a code reference into the exit function handlers stack. sub push_exit_handler { my ($func) = shift; + + _setup_exit_handlers() if @handlers == 0; push @handlers, $func; } @@ -65,6 +64,7 @@ Pop the last registered exit handler from the handlers stack. =cut sub pop_exit_handler { + _reset_exit_handlers() if @handlers == 1; pop @handlers; } @@ -83,14 +83,32 @@ sub _exit_handler { exit(127); } -$SIG{INT} = \&_exit_handler; -$SIG{HUP} = \&_exit_handler; -$SIG{QUIT} = \&_exit_handler; +my @SIGNAMES = qw(INT HUP QUIT __DIE__); +my %SIGOLD; + +sub _setup_exit_handlers +{ + foreach my $signame (@SIGNAMES) { + $SIGOLD{$signame} = $SIG{$signame}; + $SIG{$signame} = \&_exit_handler; + } +} + +sub _reset_exit_handlers +{ + foreach my $signame (@SIGNAMES) { + $SIG{$signame} = $SIGOLD{$signame}; + } +} =back =head1 CHANGES +=head2 Version 2.00 (dpkg 1.20.0) + +Hide variable: @handlers. + =head2 Version 1.01 (dpkg 1.17.2) New functions: push_exit_handler(), pop_exit_handler(), run_exit_handlers() diff --git a/scripts/Dpkg/File.pm b/scripts/Dpkg/File.pm index 884923852..6ba49a6e6 100644 --- a/scripts/Dpkg/File.pm +++ b/scripts/Dpkg/File.pm @@ -25,12 +25,26 @@ our @EXPORT = qw( ); use Exporter qw(import); +use Scalar::Util qw(openhandle); + +use Dpkg::ErrorHandling; +use Dpkg::Gettext; sub file_slurp { - my $fh = shift; + my $file = shift; + my $fh; + my $doclose = 0; + if (openhandle($file)) { + $fh = $file; + } else { + open $fh, '<', $file or syserr(g_('cannot read %s'), $fh); + $doclose = 1; + } local $/; my $data = <$fh>; + close $fh if $doclose; + return $data; } diff --git a/scripts/Dpkg/Gettext.pm b/scripts/Dpkg/Gettext.pm index 2e3e5042e..e61cdd1a0 100644 --- a/scripts/Dpkg/Gettext.pm +++ b/scripts/Dpkg/Gettext.pm @@ -28,15 +28,15 @@ package Dpkg::Gettext; use strict; use warnings; +use feature qw(state); -our $VERSION = '1.03'; +our $VERSION = '2.00'; our @EXPORT = qw( textdomain ngettext g_ P_ N_ - _g ); use Exporter qw(import); @@ -88,6 +88,19 @@ our $DEFAULT_TEXT_DOMAIN = 'dpkg-dev'; =over 4 +=item $domain = textdomain($new_domain) + +Compatibility textdomain() fallback when Locale::gettext is not available. + +If $new_domain is not undef, it will set the current domain to $new_domain. +Returns the current domain, after possibly changing it. + +=item $trans = ngettext($msgid, $msgid_plural, $n) + +Compatibility ngettext() fallback when Locale::gettext is not available. + +Returns $msgid if $n is 1 or $msgid_plural otherwise. + =item $trans = g_($msgid) Calls dgettext() on the $msgid and returns its translation for the current @@ -118,41 +131,43 @@ BEGIN { $use_gettext = not $@; } if (not $use_gettext) { - eval q{ - sub g_ { - return shift; - } - sub textdomain { - } - sub ngettext { - my ($msgid, $msgid_plural, $n) = @_; - if ($n == 1) { - return $msgid; - } else { - return $msgid_plural; - } - } - sub C_ { - my ($msgctxt, $msgid) = @_; + *g_ = sub { + return shift; + }; + *textdomain = sub { + my $new_domain = shift; + state $domain = $DEFAULT_TEXT_DOMAIN; + + $domain = $new_domain if defined $new_domain; + + return $domain; + }; + *ngettext = sub { + my ($msgid, $msgid_plural, $n) = @_; + if ($n == 1) { return $msgid; - } - sub P_ { - return ngettext(@_); + } else { + return $msgid_plural; } }; + *C_ = sub { + my ($msgctxt, $msgid) = @_; + return $msgid; + }; + *P_ = sub { + return ngettext(@_); + }; } else { - eval q{ - sub g_ { - return dgettext($DEFAULT_TEXT_DOMAIN, shift); - } - sub C_ { - my ($msgctxt, $msgid) = @_; - return dgettext($DEFAULT_TEXT_DOMAIN, - $msgctxt . GETTEXT_CONTEXT_GLUE . $msgid); - } - sub P_ { - return dngettext($DEFAULT_TEXT_DOMAIN, @_); - } + *g_ = sub { + return dgettext($DEFAULT_TEXT_DOMAIN, shift); + }; + *C_ = sub { + my ($msgctxt, $msgid) = @_; + return dgettext($DEFAULT_TEXT_DOMAIN, + $msgctxt . GETTEXT_CONTEXT_GLUE . $msgid); + }; + *P_ = sub { + return dngettext($DEFAULT_TEXT_DOMAIN, @_); }; } } @@ -173,18 +188,11 @@ sub N_ return $msgid; } -# XXX: Backwards compatibility, to be removed on VERSION 2.00. -sub _g ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines) -{ - my $msgid = shift; - - warnings::warnif('deprecated', - 'obsolete _g() function, please use g_() instead'); +=head1 CHANGES - return g_($msgid); -} +=head2 Version 2.00 (dpkg 1.20.0) -=head1 CHANGES +Remove function: _g(). =head2 Version 1.03 (dpkg 1.19.0) diff --git a/scripts/Dpkg/Index.pm b/scripts/Dpkg/Index.pm index bcee6205b..cfe86ba17 100644 --- a/scripts/Dpkg/Index.pm +++ b/scripts/Dpkg/Index.pm @@ -19,7 +19,7 @@ package Dpkg::Index; use strict; use warnings; -our $VERSION = '1.01'; +our $VERSION = '2.00'; use Dpkg::Gettext; use Dpkg::ErrorHandling; @@ -39,7 +39,7 @@ Dpkg::Index - generic index of control information =head1 DESCRIPTION -This object represent a set of Dpkg::Control objects. +This class represent a set of Dpkg::Control objects. =head1 METHODS @@ -58,7 +58,7 @@ sub new { my $self = { items => {}, order => [], - unique_tuple_key => 0, + unique_tuple_key => 1, get_key_func => sub { return $_[0]->{Package} }, type => CTRL_UNKNOWN, }; @@ -77,8 +77,7 @@ The "type" option is checked first to define default values for other options. Here are the relevant options: "get_key_func" is a function returning a key for the item passed in parameters, "unique_tuple_key" is a boolean requesting whether the default key should be the unique tuple -(default to false for backwards compatibility, but it will change to true -in dpkg 1.20.x). The index can only contain one item with a given key. +(default to true). The index can only contain one item with a given key. The "get_key_func" function used depends on the type: =over @@ -89,9 +88,9 @@ for CTRL_INFO_SRC, it is the Source field; =item * -for CTRL_INDEX_SRC and CTRL_PKG_SRC it is the Package field by default, -or the Package and Version fields (concatenated with "_") when -"unique_tuple_key" is true; +for CTRL_INDEX_SRC and CTRL_PKG_SRC it is the Package and Version fields +(concatenated with "_") when "unique_tuple_key" is true (the default), or +otherwise the Package field; =item * @@ -99,9 +98,9 @@ for CTRL_INFO_PKG it is simply the Package field; =item * -for CTRL_INDEX_PKG and CTRL_PKG_DEB it is the Package field by default, -or the Package, Version and Architecture fields (concatenated with "_") -when "unique_tuple_key" is true; +for CTRL_INDEX_PKG and CTRL_PKG_DEB it is the Package, Version and +Architecture fields (concatenated with "_") when "unique_tuple_key" is +true (the default) or otherwise the Package field; =item * @@ -165,14 +164,10 @@ sub set_options { $self->{get_key_func} = sub { return $_[0]->{Package} . '_' . $_[0]->{Version}; }; - } elsif (not defined $opts{get_key_func}) { + } else { $self->{get_key_func} = sub { return $_[0]->{Package}; }; - warnings::warnif('deprecated', - 'the default get_key_func for this control type will ' . - 'change semantics in dpkg 1.20.x , please set ' . - 'unique_tuple_key or get_key_func explicitly'); } } elsif ($t == CTRL_INDEX_PKG or $t == CTRL_PKG_DEB) { if ($opts{unique_tuple_key} // $self->{unique_tuple_key}) { @@ -180,14 +175,10 @@ sub set_options { return $_[0]->{Package} . '_' . $_[0]->{Version} . '_' . $_[0]->{Architecture}; }; - } elsif (not defined $opts{get_key_func}) { + } else { $self->{get_key_func} = sub { return $_[0]->{Package}; }; - warnings::warnif('deprecated', - 'the default get_key_func for this control type will ' . - 'change semantics in dpkg 1.20.x , please set ' . - 'unique_tuple_key or get_key_func explicitly'); } } elsif ($t == CTRL_FILE_CHANGES) { $self->{get_key_func} = sub { @@ -237,11 +228,6 @@ sub add { $self->{items}{$key} = $item; } -=item $index->load($file) - -Reads the file and creates all items parsed. Returns the number of items -parsed. Handles compressed files transparently based on their extensions. - =item $index->parse($fh, $desc) Reads the filehandle and creates all items parsed. When called multiple @@ -263,10 +249,10 @@ sub parse { return $i; } -=item $index->save($file) +=item $index->load($file) -Writes the content of the index in a file. Auto-compresses files -based on their extensions. +Reads the file and creates all items parsed. Returns the number of items +parsed. Handles compressed files transparently based on their extensions. =item $item = $index->new_item() @@ -404,17 +390,16 @@ sub sort { } } -=item $str = $index->output() +=item $str = $index->output([$fh]) =item "$index" -Get a string representation of the index. The Dpkg::Control objects are +Get a string representation of the index. The L<Dpkg::Control> objects are output in the order which they have been read or added except if the order have been changed with sort(). -=item $index->output($fh) - -Print the string representation of the index to a filehandle. +Print the string representation of the index to a filehandle if $fh has +been passed. =cut @@ -432,10 +417,19 @@ sub output { return $str; } +=item $index->save($file) + +Writes the content of the index in a file. Auto-compresses files +based on their extensions. + =back =head1 CHANGES +=head2 Version 2.00 (dpkg 1.20.0) + +Change behavior: The "unique_tuple_key" option now defaults to true. + =head2 Version 1.01 (dpkg 1.19.0) New option: Add new "unique_tuple_key" option to $index->set_options() to set diff --git a/scripts/Dpkg/Interface/Storable.pm b/scripts/Dpkg/Interface/Storable.pm index eb6078d3b..5ac078ac1 100644 --- a/scripts/Dpkg/Interface/Storable.pm +++ b/scripts/Dpkg/Interface/Storable.pm @@ -38,23 +38,23 @@ Dpkg::Interface::Storable - common methods related to object serialization =head1 DESCRIPTION Dpkg::Interface::Storable is only meant to be used as parent -class for other objects. It provides common methods that are +class for other classes. It provides common methods that are all implemented on top of two basic methods parse() and output(). =head1 BASE METHODS -Those methods must be provided by the object that wish to inherit +Those methods must be provided by the class that wish to inherit from Dpkg::Interface::Storable so that the methods provided can work. =over 4 -=item $obj->parse($fh, $desc) +=item $obj->parse($fh[, $desc]) This methods initialize the object with the data stored in the filehandle. $desc is optional and is a textual description of the filehandle used in error messages. -=item $string = $obj->output($fh) +=item $string = $obj->output([$fh]) This method returns a string representation of the object in $string and it writes the same string to $fh (if it's defined). diff --git a/scripts/Dpkg/OpenPGP.pm b/scripts/Dpkg/OpenPGP.pm index 858d3efcf..f08bd3b12 100644 --- a/scripts/Dpkg/OpenPGP.pm +++ b/scripts/Dpkg/OpenPGP.pm @@ -18,6 +18,7 @@ package Dpkg::OpenPGP; use strict; use warnings; +use POSIX qw(:sys_wait_h); use Exporter qw(import); use File::Copy; @@ -49,18 +50,21 @@ sub openpgp_sig_to_asc if ($is_openpgp_ascii_armor) { notice(g_('signature file is already OpenPGP ASCII armor, copying')); copy($sig, $asc); - return; + return $asc; } if (not find_command('gpg')) { warning(g_('cannot OpenPGP ASCII armor signature file due to missing gpg')); } + my @gpg_opts = qw(--no-options); + open my $fh_asc, '>', $asc or syserr(g_('cannot create signature file %s'), $asc); - open my $fh_gpg, '-|', 'gpg', '-o', '-', '--enarmor', $sig + open my $fh_gpg, '-|', 'gpg', @gpg_opts, '-o', '-', '--enarmor', $sig or syserr(g_('cannot execute %s program'), 'gpg'); while (my $line = <$fh_gpg>) { + next if $line =~ m/^Version: /; next if $line =~ m/^Comment: /; $line =~ s/ARMORED FILE/SIGNATURE/; @@ -71,10 +75,86 @@ sub openpgp_sig_to_asc close $fh_gpg or subprocerr('gpg'); close $fh_asc or syserr(g_('cannot write signature file %s'), $asc); - return $sig; + return $asc; } return; } +sub import_key { + my ($asc, %opts) = @_; + + $opts{require_valid_signature} //= 1; + + my @exec; + if (find_command('gpg')) { + push @exec, 'gpg'; + } elsif ($opts{require_valid_signature}) { + error(g_('cannot import key in %s since GnuPG is not installed'), + $asc); + } else { + warning(g_('cannot import key in %s since GnuPG is not installed'), + $asc); + return; + } + push @exec, '--no-options', '--no-default-keyring', '-q', '--import'; + push @exec, '--keyring', $opts{keyring}; + push @exec, $asc; + + my ($stdout, $stderr); + spawn(exec => \@exec, wait_child => 1, nocheck => 1, timeout => 10, + to_string => \$stdout, error_to_string => \$stderr); + if (WIFEXITED($?)) { + my $status = WEXITSTATUS($?); + print { *STDERR } "$stdout$stderr" if $status; + if ($status == 1 or ($status && $opts{require_valid_signature})) { + error(g_('failed to import key in %s'), $asc); + } elsif ($status) { + warning(g_('failed to import key in %s'), $asc); + } + } else { + subprocerr("@exec"); + } +} + +sub verify_signature { + my ($sig, %opts) = @_; + + $opts{require_valid_signature} //= 1; + + my @exec; + if (find_command('gpgv')) { + push @exec, 'gpgv'; + } elsif (find_command('gpg')) { + push @exec, 'gpg', '--no-default-keyring', '-q', '--verify'; + } elsif ($opts{require_valid_signature}) { + error(g_('cannot verify signature on %s since GnuPG is not installed'), + $sig); + } else { + warning(g_('cannot verify signature on %s since GnuPG is not installed'), + $sig); + return; + } + foreach my $keyring (@{$opts{keyrings}}) { + push @exec, '--keyring', $keyring; + } + push @exec, $sig; + push @exec, $opts{datafile} if exists $opts{datafile}; + + my ($stdout, $stderr); + spawn(exec => \@exec, wait_child => 1, nocheck => 1, timeout => 10, + to_string => \$stdout, error_to_string => \$stderr); + if (WIFEXITED($?)) { + my $status = WEXITSTATUS($?); + print { *STDERR } "$stdout$stderr" if $status; + if ($status == 1 or ($status && $opts{require_valid_signature})) { + error(g_('failed to verify signature on %s'), $sig); + } elsif ($status) { + warning(g_('failed to verify signature on %s'), $sig); + } + } else { + subprocerr("@exec"); + } +} + 1; diff --git a/scripts/Dpkg/Shlibs.pm b/scripts/Dpkg/Shlibs.pm index bab5e32a0..bf52cc555 100644 --- a/scripts/Dpkg/Shlibs.pm +++ b/scripts/Dpkg/Shlibs.pm @@ -116,8 +116,20 @@ sub setup_library_paths { # XXX: Deprecated. Update library paths with LD_LIBRARY_PATH. if ($ENV{LD_LIBRARY_PATH}) { + require Cwd; + my $cwd = Cwd::getcwd; + foreach my $path (split /:/, $ENV{LD_LIBRARY_PATH}) { $path =~ s{/+$}{}; + + my $realpath = Cwd::realpath($path); + next unless defined $realpath; + if ($realpath =~ m/^\Q$cwd\E/) { + warning(g_('deprecated use of LD_LIBRARY_PATH with private ' . + 'library directory which interferes with ' . + 'cross-building, please use -l option instead')); + } + # XXX: This should be added to @custom_librarypaths, but as this # is deprecated we do not care as the code will go away. push @system_librarypaths, $path; diff --git a/scripts/Dpkg/Shlibs/Objdump.pm b/scripts/Dpkg/Shlibs/Objdump.pm index 91cc06488..4cee866e7 100644 --- a/scripts/Dpkg/Shlibs/Objdump.pm +++ b/scripts/Dpkg/Shlibs/Objdump.pm @@ -1,4 +1,5 @@ # Copyright © 2007-2010 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2007-2009,2012-2015,2017-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 @@ -23,17 +24,6 @@ our $VERSION = '0.01'; use Dpkg::Gettext; use Dpkg::ErrorHandling; -use Dpkg::Path qw(find_command); -use Dpkg::Arch qw(debarch_to_gnutriplet get_build_arch get_host_arch); -use Dpkg::IPC; - -# Decide which objdump to call -our $OBJDUMP = 'objdump'; -if (get_build_arch() ne get_host_arch()) { - my $od = debarch_to_gnutriplet(get_host_arch()) . '-objdump'; - $OBJDUMP = $od if find_command($od); -} - sub new { my $this = shift; @@ -244,9 +234,12 @@ package Dpkg::Shlibs::Objdump::Object; use strict; use warnings; +use feature qw(state); use Dpkg::Gettext; use Dpkg::ErrorHandling; +use Dpkg::Path qw(find_command); +use Dpkg::Arch qw(debarch_to_gnutriplet get_build_arch get_host_arch); sub new { my $this = shift; @@ -268,9 +261,9 @@ sub reset { $self->{file} = ''; $self->{id} = ''; - $self->{SONAME} = ''; $self->{HASH} = ''; $self->{GNU_HASH} = ''; + $self->{INTERP} = 0; $self->{SONAME} = ''; $self->{NEEDED} = []; $self->{RPATH} = []; @@ -281,6 +274,14 @@ sub reset { return $self; } +sub _select_objdump { + # Decide which objdump to call + if (get_build_arch() ne get_host_arch()) { + my $od = debarch_to_gnutriplet(get_host_arch()) . '-objdump'; + return $od if find_command($od); + } + return 'objdump'; +} sub analyze { my ($self, $file) = @_; @@ -298,6 +299,7 @@ sub analyze { return; } + state $OBJDUMP = _select_objdump(); local $ENV{LC_ALL} = 'C'; open(my $objdump, '-|', $OBJDUMP, '-w', '-f', '-p', '-T', '-R', $file) or syserr(g_('cannot fork for %s'), $OBJDUMP); @@ -325,7 +327,7 @@ sub parse_objdump_output { $section = 'dyninfo'; next; } elsif (/^Program Header:/) { - $section = 'header'; + $section = 'program'; next; } elsif (/^Version definitions:/) { $section = 'verdef'; @@ -364,6 +366,10 @@ sub parse_objdump_output { $self->{RPATH} = [ split /:/, $rpath ]; } } + } elsif ($section eq 'program') { + if (/^\s*INTERP\s+/) { + $self->{INTERP} = 1; + } } elsif ($section eq 'none') { if (/^\s*.+:\s*file\s+format\s+(\S+)$/) { $self->{format} = $1; @@ -536,7 +542,8 @@ sub get_needed_libraries { sub is_executable { my $self = shift; - return exists $self->{flags}{EXEC_P} && $self->{flags}{EXEC_P}; + return (exists $self->{flags}{EXEC_P} && $self->{flags}{EXEC_P}) || + (exists $self->{INTERP} && $self->{INTERP}); } sub is_public_library { diff --git a/scripts/Dpkg/Shlibs/Symbol.pm b/scripts/Dpkg/Shlibs/Symbol.pm index 802681bf1..142992b89 100644 --- a/scripts/Dpkg/Shlibs/Symbol.pm +++ b/scripts/Dpkg/Shlibs/Symbol.pm @@ -33,6 +33,10 @@ use Dpkg::Shlibs::Cppfilt; # Supported alias types in the order of matching preference use constant ALIAS_TYPES => qw(c++ symver); +# Needed by the deprecated key, which is a correct use. +no if $Dpkg::Version::VERSION ge '1.02', + warnings => qw(Dpkg::Version::semantic_change::overload::bool); + sub new { my ($this, %args) = @_; my $class = ref($this) || $this; diff --git a/scripts/Dpkg/Shlibs/SymbolFile.pm b/scripts/Dpkg/Shlibs/SymbolFile.pm index 04d22306c..28b2111c7 100644 --- a/scripts/Dpkg/Shlibs/SymbolFile.pm +++ b/scripts/Dpkg/Shlibs/SymbolFile.pm @@ -30,6 +30,10 @@ use Dpkg::Arch qw(get_host_arch); use parent qw(Dpkg::Interface::Storable); +# Needed by the deprecated key, which is a correct use. +no if $Dpkg::Version::VERSION ge '1.02', + warnings => qw(Dpkg::Version::semantic_change::overload::bool); + my %blacklist = ( __bss_end__ => 1, # arm __bss_end => 1, # arm @@ -206,7 +210,7 @@ sub parse { my ($self, $fh, $file, %opts) = @_; my $state = $opts{state} //= {}; - if (defined $state) { + if (exists $state->{seen}) { return if exists $state->{seen}{$file}; # Avoid include loops } else { $self->{file} = $file; @@ -226,7 +230,7 @@ sub parse { error(g_('symbol information must be preceded by a header (file %s, line %s)'), $file, $.); } # Symbol specification - my $deprecated = ($1) ? $1 : 0; + my $deprecated = ($1) ? Dpkg::Version->new($1) : 0; my $sym = _new_symbol($state->{base_symbol}, deprecated => $deprecated); if ($self->create_symbol($2, base => $sym)) { $self->add_symbol($sym, ${$state->{obj_ref}}); diff --git a/scripts/Dpkg/Source/BinaryFiles.pm b/scripts/Dpkg/Source/BinaryFiles.pm new file mode 100644 index 000000000..48c84c8fc --- /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 000000000..41596a233 --- /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 index 0a940463e..3435f6c5a 100644 --- a/scripts/Dpkg/Source/Functions.pm +++ b/scripts/Dpkg/Source/Functions.pm @@ -22,6 +22,7 @@ our $VERSION = '0.01'; our @EXPORT_OK = qw( erasedir fixperms + chmod_if_needed fs_time is_binary ); @@ -70,6 +71,18 @@ sub fixperms { 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. @@ -97,30 +110,15 @@ sub fs_time($) { sub is_binary($) { my $file = shift; - # TODO: might want to reimplement what diff does, aka checking if the - # file contains \0 in the first 4Kb of data + # 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; - # Use diff to check if it's a binary file - my $diffgen; - my $diff_pid = spawn( - exec => [ 'diff', '-u', '--', '/dev/null', $file ], - env => { LC_ALL => 'C', LANG => 'C', TZ => 'UTC0' }, - to_pipe => \$diffgen, - ); - my $result = 0; - local $_; - while (<$diffgen>) { - if (m/^(?:binary|[^-+\@ ].*\bdiffer\b)/i) { - $result = 1; - last; - } elsif (m/^[-+\@ ]/) { - $result = 0; - last; - } - } - close($diffgen) or syserr('close on diff pipe'); - wait_child($diff_pid, nocheck => 1, cmdline => "diff -u -- /dev/null $file"); - return $result; + return $res >= 0; } 1; diff --git a/scripts/Dpkg/Source/Package.pm b/scripts/Dpkg/Source/Package.pm index f7851d203..337000cb8 100644 --- a/scripts/Dpkg/Source/Package.pm +++ b/scripts/Dpkg/Source/Package.pm @@ -1,5 +1,5 @@ # Copyright © 2008-2011 Raphaël Hertzog <hertzog@debian.org> -# Copyright © 2008-2015 Guillem Jover <guillem@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 @@ -24,7 +24,7 @@ Dpkg::Source::Package - manipulate Debian source packages =head1 DESCRIPTION -This module provides an object that can manipulate Debian source +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. @@ -34,7 +34,7 @@ is the one that supports the extraction of the source package. use strict; use warnings; -our $VERSION = '1.02'; +our $VERSION = '2.00'; our @EXPORT_OK = qw( get_default_diff_ignore_regex set_default_diff_ignore_regex @@ -44,6 +44,8 @@ our @EXPORT_OK = qw( 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 Dpkg::Gettext; @@ -52,10 +54,11 @@ 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 Dpkg::Source::Format; +use Dpkg::OpenPGP; my $diff_ignore_default_regex = ' # Ignore general backup files @@ -77,14 +80,8 @@ my $diff_ignore_default_regex = ' $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( +my @tar_ignore_default_pattern = qw( *.a *.la *.o @@ -166,12 +163,15 @@ sub get_default_tar_ignore_pattern { =over 4 -=item $p = Dpkg::Source::Package->new(filename => $dscfile, options => {}) +=item $p = Dpkg::Source::Package->new(%opts, options => {}) -Creates a new object corresponding to the source package described -by the file $dscfile. +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 options hash supports the following options: +The B<options> key is a hash ref which supports the following options: =over 8 @@ -204,12 +204,13 @@ source package after its extraction. =cut -# Object methods +# 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(), }; @@ -220,6 +221,10 @@ sub new { 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; } @@ -262,9 +267,8 @@ sub initialize { $self->{filename} = $fn; # Read the fields - my $fields = Dpkg::Control->new(type => CTRL_PKG_SRC); + my $fields = $self->{fields}; $fields->load($filename); - $self->{fields} = $fields; $self->{is_signed} = $fields->get_option('is_pgp_signed'); foreach my $f (qw(Source Version Files)) { @@ -281,41 +285,28 @@ sub initialize { sub upgrade_object_type { my ($self, $update_format) = @_; $update_format //= 1; - $self->{fields}{'Format'} //= '1.0'; - my $format = $self->{fields}{'Format'}; - if ($format =~ /^([\d\.]+)(?:\s+\((.*)\))?$/) { - my ($version, $variant) = ($1, $2); + my $format = $self->{fields}{'Format'} // '1.0'; + my ($major, $minor, $variant) = $self->{format}->set($format); - 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')); - } - - my $major = $version =~ s/\.[\d\.]+$//r; - my $minor; - - 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; - }; - $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, $@); - } - $module->prerequisites() if $module->can('prerequisites'); - bless $self, $module; - } else { - error(g_("invalid Format field '%s'"), $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() @@ -406,6 +397,33 @@ sub find_original_tarballs { return @tar; } +=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 = "$dir/debian/upstream/signing-key.asc"; + if (not -e $upstream_key) { + warning(g_('upstream tarball signatures but no upstream signing key')); + return; + } + + my $keyring = File::Temp->new(UNLINK => 1, SUFFIX => '.gpg'); + Dpkg::OpenPGP::import_key($upstream_key, keyring => $keyring); + foreach my $asc (@asc) { + Dpkg::OpenPGP::verify_signature($asc, + datafile => $asc =~ s/\.asc$//r, + keyrings => [ $keyring ]); + } +} + =item $bool = $p->is_signed() Returns 1 if the DSC files contains an embedded OpenPGP signature. @@ -431,52 +449,18 @@ then any problem will result in a fatal error. 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'; + my @keyrings; + + if (length $ENV{HOME} and -r "$ENV{HOME}/.gnupg/trustedkeys.gpg") { + push @keyrings, "$ENV{HOME}/.gnupg/trustedkeys.gpg"; } - 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); + foreach my $vendor_keyring (run_vendor_hook('package-keyrings')) { + if (-r $vendor_keyring) { + push @keyrings, $vendor_keyring; } } + + Dpkg::OpenPGP::verify_signature($dsc, keyrings => \@keyrings); } sub describe_cmdline_options { @@ -528,31 +512,25 @@ sub extract { 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 $?; + cp($src, $dst) + or syserror(g_('cannot copy %s to %s'), $src, $dst); } } } # Try extract - eval { $self->do_extract($newdirectory) }; - if ($@) { - run_exit_handlers(); - die $@; - } + $self->do_extract($newdirectory); # Store format if non-standard so that next build keeps the same format - if ($self->{fields}{'Format'} ne '1.0' and + 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; - open(my $format_fh, '>', $format_file) - or syserr(g_('cannot write %s'), $format_file); - print { $format_fh } $self->{fields}{'Format'} . "\n"; - close($format_fh); + $self->{format}->save($format_file); } } @@ -586,11 +564,8 @@ sub before_build { sub build { my $self = shift; - eval { $self->do_build(@_) }; - if ($@) { - run_exit_handlers(); - die $@; - } + + $self->do_build(@_); } sub after_build { @@ -620,11 +595,8 @@ sub add_file { sub commit { my $self = shift; - eval { $self->do_commit(@_) }; - if ($@) { - run_exit_handlers(); - die $@; - } + + $self->do_commit(@_); } sub do_commit { @@ -671,6 +643,18 @@ sub write_dsc { =head1 CHANGES +=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(). diff --git a/scripts/Dpkg/Source/Package/V1.pm b/scripts/Dpkg/Source/Package/V1.pm index 001d9ecd3..d91cea03b 100644 --- a/scripts/Dpkg/Source/Package/V1.pm +++ b/scripts/Dpkg/Source/Package/V1.pm @@ -267,7 +267,7 @@ sub do_build { 'argument (with v1.0 source package)')); } - $sourcestyle =~ y/X/A/; + $sourcestyle =~ y/X/a/; unless ($sourcestyle =~ m/[akpursnAKPUR]/) { usageerr(g_('source handling style -s%s not allowed with -b'), $sourcestyle); @@ -409,11 +409,18 @@ sub do_build { $sourcepackage, $tarname); } - $self->add_file($tarname) if $tarname; - if ($tarname and -e "$tarname.sig" and not -e "$tarname.asc") { - openpgp_sig_to_asc("$tarname.sig", "$tarname.asc"); + if ($tarname) { + $self->add_file($tarname); + if (-e "$tarname.sig" and not -e "$tarname.asc") { + openpgp_sig_to_asc("$tarname.sig", "$tarname.asc"); + } + } + if ($tarsign and -e $tarsign) { + info(g_('building %s using existing %s'), $sourcepackage, $tarsign); + $self->add_file($tarsign); + + $self->check_original_tarball_signature($tarsign); } - $self->add_file($tarsign) if $tarsign and -e $tarsign; if ($sourcestyle =~ m/[kpKP]/) { if (stat($origdir)) { diff --git a/scripts/Dpkg/Source/Package/V2.pm b/scripts/Dpkg/Source/Package/V2.pm index 818e32ddc..d84fce2dd 100644 --- a/scripts/Dpkg/Source/Package/V2.pm +++ b/scripts/Dpkg/Source/Package/V2.pm @@ -37,8 +37,9 @@ 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 is_binary fs_time); +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; @@ -399,7 +400,8 @@ sub _generate_patch { # Identify original tarballs my ($tarfile, %addonfile); my $comp_ext_regex = compression_get_file_extension_regex(); - my @origtarballs; + my @origtarfiles; + my @origtarsigns; foreach my $file (sort $self->find_original_tarballs()) { if ($file =~ /\.orig\.tar\.$comp_ext_regex$/) { if (defined($tarfile)) { @@ -407,20 +409,23 @@ sub _generate_patch { 'one is allowed'), $tarfile, $file); } $tarfile = $file; - push @origtarballs, $file; - $self->add_file($file); - if (-e "$file.sig" and not -e "$file.asc") { - openpgp_sig_to_asc("$file.sig", "$file.asc"); - } - $self->add_file("$file.asc") if -e "$file.asc"; } elsif ($file =~ /\.orig-([[:alnum:]-]+)\.tar\.$comp_ext_regex$/) { $addonfile{$1} = $file; - push @origtarballs, $file; - $self->add_file($file); - if (-e "$file.sig" and not -e "$file.asc") { - openpgp_sig_to_asc("$file.sig", "$file.asc"); - } - $self->add_file("$file.asc") if -e "$file.asc"; + } else { + next; + } + + push @origtarfiles, $file; + $self->add_file($file); + + # Check for an upstream signature. + if (-e "$file.sig" and not -e "$file.asc") { + openpgp_sig_to_asc("$file.sig", "$file.asc"); + } + if (-e "$file.asc") { + push @origtarfiles, "$file.asc"; + push @origtarsigns, "$file.asc"; + $self->add_file("$file.asc") } } @@ -428,8 +433,12 @@ sub _generate_patch { $self->_upstream_tarball_template()) unless $tarfile; if ($opts{usage} eq 'build') { - info(g_('building %s using existing %s'), - $self->{fields}{'Source'}, "@origtarballs"); + foreach my $origtarfile (@origtarfiles) { + info(g_('building %s using existing %s'), + $self->{fields}{'Source'}, $origtarfile); + } + + $self->check_original_tarball_signature(@origtarsigns); } # Unpack a second copy for comparison @@ -509,50 +518,12 @@ sub do_build { my $basenamerev = $self->get_basename(1); # Check if the debian directory contains unwanted binary files - my $binaryfiles = Dpkg::Source::Package::V2::BinaryFiles->new($dir); - my $unwanted_binaries = 0; - my $check_binary = sub { - if (-f and is_binary($_)) { - my $fn = File::Spec->abs2rel($_, $dir); - $binaryfiles->new_binary_found($fn); - unless ($include_binaries or $binaryfiles->binary_is_allowed($fn)) { - errormsg(g_('unwanted binary file: %s'), $fn); - $unwanted_binaries++; - } - } - }; - my $tar_ignore_glob = '{' . join(',', - map { s/,/\\,/rg } @{$self->{options}{tar_ignore}}) . '}'; - 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, $dir); - my $cwd = getcwd(); - # Apply the pattern both from the top dir and from the inspected dir - chdir $dir or syserr(g_("unable to chdir to '%s'"), $dir); - $exclude{$_} = 1 foreach glob($tar_ignore_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($tar_ignore_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($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; + 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 { @@ -616,17 +587,25 @@ sub do_build { 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'); } - my $text; if (-f $ph) { - open(my $ph_fh, '<', $ph) or syserr(g_('cannot read %s'), $ph); - $text = file_slurp($ph_fh); - close($ph_fh); - return $text; + 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 => File::Spec->catfile($dir, 'debian', 'changelog')); return '' if not defined $ch_info; @@ -642,6 +621,7 @@ it.\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--- @@ -665,7 +645,7 @@ sub register_patch { if (-s $patch_file) { copy($patch_file, $patch) or syserr(g_('failed to copy %s to %s'), $patch_file, $patch); - chmod(0666 & ~ umask(), $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) @@ -706,7 +686,7 @@ sub do_commit { error(g_("patch file '%s' doesn't exist"), $tmpdiff) if not -e $tmpdiff; } - my $binaryfiles = Dpkg::Source::Package::V2::BinaryFiles->new($dir); + my $binaryfiles = Dpkg::Source::BinaryFiles->new($dir); my $handle_binary = sub { my ($self, $old, $new, %opts) = @_; my $fn = File::Spec->abs2rel($new, $dir); @@ -749,86 +729,4 @@ sub do_commit { info(g_('local changes have been recorded in a new patch: %s'), $patch); } -package Dpkg::Source::Package::V2::BinaryFiles; - -use Dpkg::ErrorHandling; -use Dpkg::Gettext; - -use File::Path qw(make_path); -use File::Spec; - -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; -} - 1; diff --git a/scripts/Dpkg/Source/Package/V3/Bzr.pm b/scripts/Dpkg/Source/Package/V3/Bzr.pm index f0752c0b1..13d49c742 100644 --- a/scripts/Dpkg/Source/Package/V3/Bzr.pm +++ b/scripts/Dpkg/Source/Package/V3/Bzr.pm @@ -176,7 +176,7 @@ sub do_extract { my @files = $self->get_files(); if (@files > 1) { - error(g_('format v3.0 uses only one source file')); + error(g_('format v3.0 (bzr) uses only one source file')); } my $tarfile = $files[0]; my $comp_ext_regex = compression_get_file_extension_regex(); diff --git a/scripts/Dpkg/Source/Package/V3/Native.pm b/scripts/Dpkg/Source/Package/V3/Native.pm index b53a30f3f..1d0de2b0f 100644 --- a/scripts/Dpkg/Source/Package/V3/Native.pm +++ b/scripts/Dpkg/Source/Package/V3/Native.pm @@ -49,7 +49,7 @@ sub do_extract { 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 v1.0 source package')) if $tarfile; + error(g_('multiple tarfiles in native source package')) if $tarfile; $tarfile = $file; } else { error(g_('unrecognized file for a native source package: %s'), $file); diff --git a/scripts/Dpkg/Source/Package/V3/Quilt.pm b/scripts/Dpkg/Source/Package/V3/Quilt.pm index 9718ffa2d..45237d26a 100644 --- a/scripts/Dpkg/Source/Package/V3/Quilt.pm +++ b/scripts/Dpkg/Source/Package/V3/Quilt.pm @@ -28,7 +28,7 @@ use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Version; use Dpkg::Source::Patch; -use Dpkg::Source::Functions qw(erasedir fs_time); +use Dpkg::Source::Functions qw(erasedir chmod_if_needed fs_time); use Dpkg::Source::Quilt; use Dpkg::Exit; @@ -142,6 +142,8 @@ sub apply_patches { 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 @@ -249,7 +251,7 @@ sub register_patch { if (-s $tmpdiff) { copy($tmpdiff, $patch) or syserr(g_('failed to copy %s to %s'), $tmpdiff, $patch); - chmod(0666 & ~ umask(), $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); diff --git a/scripts/Dpkg/Source/Patch.pm b/scripts/Dpkg/Source/Patch.pm index e5ad5424b..25d56335d 100644 --- a/scripts/Dpkg/Source/Patch.pm +++ b/scripts/Dpkg/Source/Patch.pm @@ -148,7 +148,6 @@ sub add_diff_directory { # TODO: make this function more configurable # - offer to disable some checks my $basedir = $opts{basedirname} || basename($new); - my $inc_removal = $opts{include_removal} // 0; my $diff_ignore; if ($opts{diff_ignore_func}) { $diff_ignore = $opts{diff_ignore_func}; @@ -226,11 +225,13 @@ sub add_diff_directory { return if $files_in_new{$fn}; lstat("$old/$fn") or syserr(g_('cannot stat file %s'), "$old/$fn"); if (-f _) { - if ($inc_removal) { + 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']; - } else { - warning(g_('ignoring deletion of file %s, use --include-removal to override'), $fn); } } elsif (-d _) { warning(g_('ignoring deletion of directory %s'), $fn); diff --git a/scripts/Dpkg/Source/Quilt.pm b/scripts/Dpkg/Source/Quilt.pm index 55b3fbaf8..78a4fdf9a 100644 --- a/scripts/Dpkg/Source/Quilt.pm +++ b/scripts/Dpkg/Source/Quilt.pm @@ -30,7 +30,7 @@ use File::Basename; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Source::Patch; -use Dpkg::Source::Functions qw(erasedir fs_time); +use Dpkg::Source::Functions qw(erasedir chmod_if_needed fs_time); use Dpkg::Vendor qw(get_current_vendor); sub new { @@ -374,7 +374,7 @@ sub restore_quilt_backup_files { unless (link($_, $target)) { copy($_, $target) or syserr(g_('failed to copy %s to %s'), $_, $target); - chmod((stat(_))[2], $target) + chmod_if_needed((stat _)[2], $target) or syserr(g_("unable to change permission of '%s'"), $target); } } else { diff --git a/scripts/Dpkg/Substvars.pm b/scripts/Dpkg/Substvars.pm index 1e9f90173..27107fe3d 100644 --- a/scripts/Dpkg/Substvars.pm +++ b/scripts/Dpkg/Substvars.pm @@ -19,7 +19,7 @@ package Dpkg::Substvars; use strict; use warnings; -our $VERSION = '1.06'; +our $VERSION = '2.00'; use Dpkg (); use Dpkg::Arch qw(get_host_arch); @@ -39,8 +39,7 @@ Dpkg::Substvars - handle variable substitution in strings =head1 DESCRIPTION -It provides some an object which is able to substitute variables in -strings. +It provides a class which is able to substitute variables in strings. =cut @@ -169,25 +168,6 @@ sub mark_as_used { $self->{attr}{$key} |= SUBSTVAR_ATTR_USED; } -=item $s->no_warn($key) - -Obsolete function, use mark_as_used() instead. - -=cut - -sub no_warn { - my ($self, $key) = @_; - - warnings::warnif('deprecated', - 'obsolete no_warn() function, use mark_as_used() instead'); - - $self->mark_as_used($key); -} - -=item $s->load($file) - -Add new substitutions read from $file. - =item $s->parse($fh, $desc) Add new substitutions read from the filehandle. $desc is used to identify @@ -217,6 +197,10 @@ sub parse { return $count } +=item $s->load($file) + +Add new substitutions read from $file. + =item $s->set_version_substvars($sourceversion, $binaryversion) Defines ${binary:Version}, ${source:Version} and @@ -342,7 +326,8 @@ sub substvars { g_('obsolete substitution variable ${%s}'), $vn); } } else { - warning($opts{msg_prefix} . g_('unknown substitution variable ${%s}'), + warning($opts{msg_prefix} . + g_('substitution variable ${%s} used, but is not defined'), $vn) unless $opts{no_warn}; $v = $lhs . $rhs; } @@ -366,7 +351,8 @@ sub warn_about_unused { # that they are not required in the current situation # (example: debhelper's misc:Depends in many cases) next if $self->{vars}{$vn} eq ''; - warning($opts{msg_prefix} . g_('unused substitution variable ${%s}'), + warning($opts{msg_prefix} . + g_('substitution variable ${%s} unused, but is defined'), $vn); } } @@ -403,20 +389,15 @@ sub filter { } } -=item $s->save($file) - -Store all substitutions variables except the automatic ones in the -indicated file. - =item "$s" Return a string representation of all substitutions variables except the automatic ones. -=item $str = $s->output($fh) +=item $str = $s->output([$fh]) -Print all substitutions variables except the automatic ones in the -filehandle and return the content written. +Return all substitutions variables except the automatic ones. If $fh +is passed print them into the filehandle. =cut @@ -433,10 +414,19 @@ sub output { return $str; } +=item $s->save($file) + +Store all substitutions variables except the automatic ones in the +indicated file. + =back =head1 CHANGES +=head2 Version 2.00 (dpkg 1.20.0) + +Remove method: $s->no_warn(). + =head2 Version 1.06 (dpkg 1.19.0) New method: $s->set_desc_substvars(). diff --git a/scripts/Dpkg/Vendor/Debian.pm b/scripts/Dpkg/Vendor/Debian.pm index e0fd01113..c3e580da7 100644 --- a/scripts/Dpkg/Vendor/Debian.pm +++ b/scripts/Dpkg/Vendor/Debian.pm @@ -36,11 +36,11 @@ use parent qw(Dpkg::Vendor::Default); =head1 NAME -Dpkg::Vendor::Debian - Debian vendor object +Dpkg::Vendor::Debian - Debian vendor class =head1 DESCRIPTION -This vendor object customizes the behaviour of dpkg scripts for Debian +This vendor class customizes the behaviour of dpkg scripts for Debian specific behavior and policies. =cut @@ -51,9 +51,6 @@ sub run_hook { if ($hook eq 'package-keyrings') { return ('/usr/share/keyrings/debian-keyring.gpg', '/usr/share/keyrings/debian-maintainers.gpg'); - } elsif ($hook eq 'keyrings') { - warnings::warnif('deprecated', 'deprecated keyrings vendor hook'); - return $self->run_hook('package-keyrings', @params); } elsif ($hook eq 'archive-keyrings') { return ('/usr/share/keyrings/debian-archive-keyring.gpg'); } elsif ($hook eq 'archive-keyrings-historic') { @@ -81,23 +78,13 @@ sub run_hook { $self->_add_build_flags(@params); } elsif ($hook eq 'builtin-system-build-paths') { return qw(/build/); + } elsif ($hook eq 'build-tainted-by') { + return $self->_build_tainted_by(); } else { return $self->SUPER::run_hook($hook, @params); } } -sub _parse_feature_area { - my ($self, $area, $use_feature) = @_; - - require Dpkg::BuildOptions; - - # Adjust features based on user or maintainer's desires. - my $opts = Dpkg::BuildOptions->new(envvar => 'DEB_BUILD_OPTIONS'); - $opts->parse_features($area, $use_feature); - $opts = Dpkg::BuildOptions->new(envvar => 'DEB_BUILD_MAINT_OPTIONS'); - $opts->parse_features($area, $use_feature); -} - sub _add_build_flags { my ($self, $flags) = @_; @@ -112,6 +99,7 @@ sub _add_build_flags { }, reproducible => { timeless => 1, + fixfilepath => 0, fixdebugpath => 1, }, sanitize => { @@ -141,9 +129,15 @@ sub _add_build_flags { ## Setup + require Dpkg::BuildOptions; + # Adjust features based on user or maintainer's desires. + my $opts_build = Dpkg::BuildOptions->new(envvar => 'DEB_BUILD_OPTIONS'); + my $opts_maint = Dpkg::BuildOptions->new(envvar => 'DEB_BUILD_MAINT_OPTIONS'); + foreach my $area (sort keys %use_feature) { - $self->_parse_feature_area($area, $use_feature{$area}); + $opts_build->parse_features($area, $use_feature{$area}); + $opts_maint->parse_features($area, $use_feature{$area}); } require Dpkg::Arch; @@ -156,6 +150,22 @@ sub _add_build_flags { ($abi, $os, $cpu) = ('', '', ''); } + ## Global defaults + + my $default_flags; + if ($opts_build->has('noopt')) { + $default_flags = '-g -O0'; + } else { + $default_flags = '-g -O2'; + } + $flags->append('CFLAGS', $default_flags); + $flags->append('CXXFLAGS', $default_flags); + $flags->append('OBJCFLAGS', $default_flags); + $flags->append('OBJCXXFLAGS', $default_flags); + $flags->append('FFLAGS', $default_flags); + $flags->append('FCFLAGS', $default_flags); + $flags->append('GCJFLAGS', $default_flags); + ## Area: future if ($use_feature{future}{lfs}) { @@ -172,8 +182,21 @@ sub _add_build_flags { # Warnings that detect actual bugs. if ($use_feature{qa}{bug}) { - foreach my $warnflag (qw(array-bounds clobbered volatile-register-var - implicit-function-declaration)) { + # C flags + my @cflags = qw( + implicit-function-declaration + ); + foreach my $warnflag (@cflags) { + $flags->append('CFLAGS', "-Werror=$warnflag"); + } + + # C/C++ flags + my @cfamilyflags = qw( + array-bounds + clobbered + volatile-register-var + ); + foreach my $warnflag (@cfamilyflags) { $flags->append('CFLAGS', "-Werror=$warnflag"); $flags->append('CXXFLAGS', "-Werror=$warnflag"); } @@ -195,16 +218,18 @@ sub _add_build_flags { my $build_path; # Mask features that might have an unsafe usage. - if ($use_feature{reproducible}{fixdebugpath}) { + if ($use_feature{reproducible}{fixfilepath} or + $use_feature{reproducible}{fixdebugpath}) { require Cwd; - $build_path = $ENV{DEB_BUILD_PATH} || Cwd::cwd(); + $build_path = $ENV{DEB_BUILD_PATH} || Cwd::getcwd(); # If we have any unsafe character in the path, disable the flag, # so that we do not need to worry about escaping the characters # on output. if ($build_path =~ m/[^-+:.0-9a-zA-Z~\/_]/) { - $use_feature{fixdebugpath} = 0; + $use_feature{reproducible}{fixfilepath} = 0; + $use_feature{reproducible}{fixdebugpath} = 0; } } @@ -213,9 +238,19 @@ sub _add_build_flags { $flags->append('CPPFLAGS', '-Wdate-time'); } - # Avoid storing the build path in the debug symbols. - if ($use_feature{reproducible}{fixdebugpath}) { - my $map = '-fdebug-prefix-map=' . $build_path . '=.'; + # Avoid storing the build path in the binaries. + if ($use_feature{reproducible}{fixfilepath} or + $use_feature{reproducible}{fixdebugpath}) { + my $map; + + # -ffile-prefix-map is a superset of -fdebug-prefix-map, prefer it + # if both are set. + if ($use_feature{reproducible}{fixfilepath}) { + $map = '-ffile-prefix-map=' . $build_path . '=.'; + } else { + $map = '-fdebug-prefix-map=' . $build_path . '=.'; + } + $flags->append('CFLAGS', $map); $flags->append('CXXFLAGS', $map); $flags->append('OBJCFLAGS', $map); @@ -267,8 +302,24 @@ sub _add_build_flags { # Mask builtin features that are not enabled by default in the compiler. my %builtin_pie_arch = map { $_ => 1 } qw( - amd64 arm64 armel armhf i386 kfreebsd-amd64 kfreebsd-i386 - mips mipsel mips64el powerpc ppc64 ppc64el s390x sparc sparc64 + amd64 + arm64 + armel + armhf + hurd-i386 + i386 + kfreebsd-amd64 + kfreebsd-i386 + mips + mipsel + mips64el + powerpc + ppc64 + ppc64el + riscv64 + s390x + sparc + sparc64 ); if (not exists $builtin_pie_arch{$arch}) { $builtin_feature{hardening}{pie} = 0; @@ -295,7 +346,7 @@ sub _add_build_flags { } # Mask features that might be influenced by other flags. - if ($flags->{build_options}->has('noopt')) { + if ($opts_build->has('noopt')) { # glibc 2.16 and later warn when using -O0 and _FORTIFY_SOURCE. $use_feature{hardening}{fortify} = 0; } @@ -400,6 +451,38 @@ sub _add_build_flags { } } +sub _build_tainted_by { + my $self = shift; + my %tainted; + + foreach my $pathname (qw(/bin /sbin /lib /lib32 /libo32 /libx32 /lib64)) { + next unless -l $pathname; + + my $linkname = readlink $pathname; + if ($linkname eq "usr$pathname") { + $tainted{'merged-usr-via-symlinks'} = 1; + last; + } + } + + require File::Find; + my %usr_local_types = ( + configs => [ qw(etc) ], + includes => [ qw(include) ], + programs => [ qw(bin sbin) ], + libraries => [ qw(lib) ], + ); + foreach my $type (keys %usr_local_types) { + File::Find::find({ + wanted => sub { $tainted{"usr-local-has-$type"} = 1 if -f }, + no_chdir => 1, + }, grep { -d } map { "/usr/local/$_" } @{$usr_local_types{$type}}); + } + + my @tainted = sort keys %tainted; + return @tainted; +} + =head1 CHANGES =head2 Version 0.xx diff --git a/scripts/Dpkg/Vendor/Default.pm b/scripts/Dpkg/Vendor/Default.pm index 40815efde..42b0f0405 100644 --- a/scripts/Dpkg/Vendor/Default.pm +++ b/scripts/Dpkg/Vendor/Default.pm @@ -20,7 +20,7 @@ use warnings; our $VERSION = '0.01'; -# If you use this file as template to create a new vendor object, please +# If you use this file as template to create a new vendor class, please # uncomment the following lines #use parent qw(Dpkg::Vendor::Default); @@ -28,12 +28,12 @@ our $VERSION = '0.01'; =head1 NAME -Dpkg::Vendor::Default - default vendor object +Dpkg::Vendor::Default - default vendor class =head1 DESCRIPTION -A vendor object is used to provide vendor specific behaviour -in various places. This is the default object used in case +A vendor class is used to provide vendor specific behaviour +in various places. This is the default class used in case there's none for the current vendor or in case the vendor could not be identified (see Dpkg::Vendor documentation). @@ -140,6 +140,14 @@ field will be created if the current directory is "/build/dpkg-1.18.0". If the list contains "/", the path will always be recorded. If the list is empty, the current path will never be recorded. +=item build-tainted-by () + +The hook is called by dpkg-genbuildinfo to determine if the current system +has been tainted in some way that could affect the resulting build, which +will be recorded in the B<Build-Tainted-By> field (since dpkg 1.19.5). It +takes no parameters, but returns a (possibly empty) list of tainted reason +tags (formed by alphanumeric and dash characters). + =back =cut @@ -149,9 +157,6 @@ sub run_hook { if ($hook eq 'before-source-build') { my $srcpkg = shift @params; - } elsif ($hook eq 'keyrings') { - warnings::warnif('deprecated', 'obsolete keyrings vendor hook'); - return (); } elsif ($hook eq 'package-keyrings') { return (); } elsif ($hook eq 'archive-keyrings') { @@ -172,6 +177,8 @@ sub run_hook { my $flags = shift @params; } elsif ($hook eq 'builtin-system-build-paths') { return (); + } elsif ($hook eq 'build-tainted-by') { + return (); } # Default return value for unknown/unimplemented hooks diff --git a/scripts/Dpkg/Vendor/Ubuntu.pm b/scripts/Dpkg/Vendor/Ubuntu.pm index eb2dffefe..ddee2a192 100644 --- a/scripts/Dpkg/Vendor/Ubuntu.pm +++ b/scripts/Dpkg/Vendor/Ubuntu.pm @@ -34,11 +34,11 @@ use parent qw(Dpkg::Vendor::Debian); =head1 NAME -Dpkg::Vendor::Ubuntu - Ubuntu vendor object +Dpkg::Vendor::Ubuntu - Ubuntu vendor class =head1 DESCRIPTION -This vendor object customizes the behaviour of dpkg scripts for Ubuntu +This vendor class customizes the behaviour of dpkg scripts for Ubuntu specific behavior and policies. =cut @@ -98,6 +98,9 @@ sub run_hook { } elsif ($hook eq 'update-buildflags') { my $flags = shift @params; + # Run the Debian hook to add hardening flags + $self->SUPER::run_hook($hook, $flags); + require Dpkg::BuildOptions; my $build_opts = Dpkg::BuildOptions->new(); @@ -109,15 +112,14 @@ sub run_hook { if (Dpkg::Arch::debarch_eq($arch, 'ppc64el')) { for my $flag (qw(CFLAGS CXXFLAGS OBJCFLAGS OBJCXXFLAGS GCJFLAGS FFLAGS FCFLAGS)) { - $flags->set($flag, '-g -O3', 'vendor'); + my $value = $flags->get($flag); + $value =~ s/-O[0-9]/-O3/; + $flags->set($flag, $value); } } } # Per https://wiki.ubuntu.com/DistCompilerFlags - $flags->set('LDFLAGS', '-Wl,-Bsymbolic-functions', 'vendor'); - - # Run the Debian hook to add hardening flags - $self->SUPER::run_hook($hook, $flags); + $flags->prepend('LDFLAGS', '-Wl,-Bsymbolic-functions'); } else { return $self->SUPER::run_hook($hook, @params); } diff --git a/scripts/Dpkg/Version.pm b/scripts/Dpkg/Version.pm index 477082b67..51d46c543 100644 --- a/scripts/Dpkg/Version.pm +++ b/scripts/Dpkg/Version.pm @@ -20,8 +20,9 @@ package Dpkg::Version; use strict; use warnings; +use warnings::register qw(semantic_change::overload::bool); -our $VERSION = '1.01'; +our $VERSION = '1.03'; our @EXPORT = qw( version_compare version_compare_relation @@ -55,7 +56,7 @@ use overload '<=>' => \&_comparison, 'cmp' => \&_comparison, '""' => sub { return $_[0]->as_string(); }, - 'bool' => sub { return $_[0]->as_string() if $_[0]->is_valid(); }, + 'bool' => sub { return $_[0]->is_valid(); }, 'fallback' => 1; =encoding utf8 @@ -121,8 +122,20 @@ sub new { =item boolean evaluation When the Dpkg::Version object is used in a boolean evaluation (for example -in "if ($v)" or "$v || 'default'") it returns its string representation -if the version stored is valid ($v->is_valid()) and undef otherwise. +in "if ($v)" or "$v ? \"$v\" : 'default'") it returns true if the version +stored is valid ($v->is_valid()) and false otherwise. + +B<Notice>: Between dpkg 1.15.7.2 and 1.19.1 this overload used to return +$v->as_string() if $v->is_valid(), a breaking change in behavior that caused +"0" versions to be evaluated as false. To catch any possibly intended code +that relied on those semantics, this overload will emit a warning with +category "Dpkg::Version::semantic_change::overload::bool" until dpkg 1.20.x. +Once fixed, or for already valid code the warning can be quiesced with + + no if $Dpkg::Version::VERSION ge '1.02', + warnings => qw(Dpkg::Version::semantic_change::overload::bool); + +added after the C<use Dpkg::Version>. =item $v->is_valid() @@ -455,6 +468,14 @@ sub version_check($) { =head1 CHANGES +=head2 Version 1.03 (dpkg 1.20.0) + +Remove deprecation warning from semantic change in 1.02. + +=head2 Version 1.02 (dpkg 1.19.1) + +Semantic change: bool evaluation semantics restored to their original behavior. + =head2 Version 1.01 (dpkg 1.17.0) New argument: Accept an options argument in $v->as_string(). |