Файловый менеджер - Редактировать - /var/www/html/Dpkg.zip
Ðазад
PK ! _� ��, �, Substvars.pmnu �[��� # Copyright © 2006-2009, 2012-2015 Guillem Jover <guillem@debian.org> # Copyright © 2007-2010 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Substvars; use strict; use warnings; our $VERSION = '2.00'; use Dpkg (); use Dpkg::Arch qw(get_host_arch); use Dpkg::Vendor qw(get_current_vendor); use Dpkg::Version; use Dpkg::ErrorHandling; use Dpkg::Gettext; use parent qw(Dpkg::Interface::Storable); my $maxsubsts = 50; =encoding utf8 =head1 NAME Dpkg::Substvars - handle variable substitution in strings =head1 DESCRIPTION It provides a class which is able to substitute variables in strings. =cut use constant { SUBSTVAR_ATTR_USED => 1, SUBSTVAR_ATTR_AUTO => 2, SUBSTVAR_ATTR_AGED => 4, }; =head1 METHODS =over 8 =item $s = Dpkg::Substvars->new($file) Create a new object that can do substitutions. By default it contains generic substitutions like ${Newline}, ${Space}, ${Tab}, ${dpkg:Version} and ${dpkg:Upstream-Version}. Additional substitutions will be read from the $file passed as parameter. It keeps track of which substitutions were actually used (only counting substvars(), not get()), and warns about unused substvars when asked to. The substitutions that are always present are not included in these warnings. =cut sub new { my ($this, $arg) = @_; my $class = ref($this) || $this; my $self = { vars => { 'Newline' => "\n", 'Space' => ' ', 'Tab' => "\t", 'dpkg:Version' => $Dpkg::PROGVERSION, 'dpkg:Upstream-Version' => $Dpkg::PROGVERSION, }, attr => {}, msg_prefix => '', }; $self->{vars}{'dpkg:Upstream-Version'} =~ s/-[^-]+$//; bless $self, $class; my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; $self->{attr}{$_} = $attr foreach keys %{$self->{vars}}; if ($arg) { $self->load($arg) if -e $arg; } return $self; } =item $s->set($key, $value) Add/replace a substitution. =cut sub set { my ($self, $key, $value, $attr) = @_; $attr //= 0; $self->{vars}{$key} = $value; $self->{attr}{$key} = $attr; } =item $s->set_as_used($key, $value) Add/replace a substitution and mark it as used (no warnings will be produced even if unused). =cut sub set_as_used { my ($self, $key, $value) = @_; $self->set($key, $value, SUBSTVAR_ATTR_USED); } =item $s->set_as_auto($key, $value) Add/replace a substitution and mark it as used and automatic (no warnings will be produced even if unused). =cut sub set_as_auto { my ($self, $key, $value) = @_; $self->set($key, $value, SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO); } =item $s->get($key) Get the value of a given substitution. =cut sub get { my ($self, $key) = @_; return $self->{vars}{$key}; } =item $s->delete($key) Remove a given substitution. =cut sub delete { my ($self, $key) = @_; delete $self->{attr}{$key}; return delete $self->{vars}{$key}; } =item $s->mark_as_used($key) Prevents warnings about a unused substitution, for example if it is provided by default. =cut sub mark_as_used { my ($self, $key) = @_; $self->{attr}{$key} |= SUBSTVAR_ATTR_USED; } =item $s->parse($fh, $desc) Add new substitutions read from the filehandle. $desc is used to identify the filehandle in error messages. Returns the number of substitutions that have been parsed with success. =cut sub parse { my ($self, $fh, $varlistfile) = @_; my $count = 0; local $_; binmode($fh); while (<$fh>) { next if m/^\s*\#/ || !m/\S/; s/\s*\n$//; if (! m/^(\w[-:0-9A-Za-z]*)\=(.*)$/) { error(g_('bad line in substvars file %s at line %d'), $varlistfile, $.); } $self->set($1, $2); $count++; } 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 ${source:Upstream-Version} based on the given version strings. These will never be warned about when unused. =cut sub set_version_substvars { my ($self, $sourceversion, $binaryversion) = @_; # Handle old function signature taking only one argument. $binaryversion //= $sourceversion; # For backwards compatibility on binNMUs that do not use the Binary-Only # field on the changelog, always fix up the source version. $sourceversion =~ s/\+b[0-9]+$//; my $vs = Dpkg::Version->new($sourceversion, check => 1); if (not defined $vs) { error(g_('invalid source version %s'), $sourceversion); } my $upstreamversion = $vs->as_string(omit_revision => 1); my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; $self->set('binary:Version', $binaryversion, $attr); $self->set('source:Version', $sourceversion, $attr); $self->set('source:Upstream-Version', $upstreamversion, $attr); # XXX: Source-Version is now obsolete, remove in 1.19.x. $self->set('Source-Version', $binaryversion, $attr | SUBSTVAR_ATTR_AGED); } =item $s->set_arch_substvars() Defines architecture variables: ${Arch}. This will never be warned about when unused. =cut sub set_arch_substvars { my $self = shift; my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; $self->set('Arch', get_host_arch(), $attr); } =item $s->set_vendor_substvars() Defines vendor variables: ${vendor:Name} and ${vendor:Id}. These will never be warned about when unused. =cut sub set_vendor_substvars { my ($self, $desc) = @_; my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; my $vendor = get_current_vendor(); $self->set('vendor:Name', $vendor, $attr); $self->set('vendor:Id', lc $vendor, $attr); } =item $s->set_desc_substvars() Defines source description variables: ${source:Synopsis} and ${source:Extended-Description}. These will never be warned about when unused. =cut sub set_desc_substvars { my ($self, $desc) = @_; my ($synopsis, $extended) = split /\n/, $desc, 2; my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; $self->set('source:Synopsis', $synopsis, $attr); $self->set('source:Extended-Description', $extended, $attr); } =item $s->set_field_substvars($ctrl, $prefix) Defines field variables from a Dpkg::Control object, with each variable having the form "${$prefix:$field}". They will never be warned about when unused. =cut sub set_field_substvars { my ($self, $ctrl, $prefix) = @_; foreach my $field (keys %{$ctrl}) { $self->set_as_auto("$prefix:$field", $ctrl->{$field}); } } =item $newstring = $s->substvars($string) Substitutes variables in $string and return the result in $newstring. =cut sub substvars { my ($self, $v, %opts) = @_; my $lhs; my $vn; my $rhs = ''; my $count = 0; $opts{msg_prefix} //= $self->{msg_prefix}; $opts{no_warn} //= 0; while ($v =~ m/^(.*?)\$\{([-:0-9a-z]+)\}(.*)$/si) { # If we have consumed more from the leftover data, then # reset the recursive counter. $count = 0 if (length($3) < length($rhs)); if ($count >= $maxsubsts) { error($opts{msg_prefix} . g_("too many substitutions - recursive ? - in '%s'"), $v); } $lhs = $1; $vn = $2; $rhs = $3; if (defined($self->{vars}{$vn})) { $v = $lhs . $self->{vars}{$vn} . $rhs; $self->mark_as_used($vn); $count++; if ($self->{attr}{$vn} & SUBSTVAR_ATTR_AGED) { error($opts{msg_prefix} . g_('obsolete substitution variable ${%s}'), $vn); } } else { warning($opts{msg_prefix} . g_('substitution variable ${%s} used, but is not defined'), $vn) unless $opts{no_warn}; $v = $lhs . $rhs; } } return $v; } =item $s->warn_about_unused() Issues warning about any variables that were set, but not used. =cut sub warn_about_unused { my ($self, %opts) = @_; $opts{msg_prefix} //= $self->{msg_prefix}; foreach my $vn (sort keys %{$self->{vars}}) { next if $self->{attr}{$vn} & SUBSTVAR_ATTR_USED; # Empty substitutions variables are ignored on the basis # 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_('substitution variable ${%s} unused, but is defined'), $vn); } } =item $s->set_msg_prefix($prefix) Define a prefix displayed before all warnings/error messages output by the module. =cut sub set_msg_prefix { my ($self, $prefix) = @_; $self->{msg_prefix} = $prefix; } =item $s->filter(remove => $rmfunc) =item $s->filter(keep => $keepfun) Filter the substitution variables, either removing or keeping all those that return true when $rmfunc->($key) or $keepfunc->($key) is called. =cut sub filter { my ($self, %opts) = @_; my $remove = $opts{remove} // sub { 0 }; my $keep = $opts{keep} // sub { 1 }; foreach my $vn (keys %{$self->{vars}}) { $self->delete($vn) if $remove->($vn) or not $keep->($vn); } } =item "$s" Return a string representation of all substitutions variables except the automatic ones. =item $str = $s->output([$fh]) Return all substitutions variables except the automatic ones. If $fh is passed print them into the filehandle. =cut sub output { my ($self, $fh) = @_; my $str = ''; # Store all non-automatic substitutions only foreach my $vn (sort keys %{$self->{vars}}) { next if $self->{attr}{$vn} & SUBSTVAR_ATTR_AUTO; my $line = "$vn=" . $self->{vars}{$vn} . "\n"; print { $fh } $line if defined $fh; $str .= $line; } 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(). New method: $s->set_vendor_substvars(). =head2 Version 1.06 (dpkg 1.19.0) New method: $s->set_desc_substvars(). =head2 Version 1.05 (dpkg 1.18.11) Obsolete substvar: Emit an error on Source-Version substvar usage. New return: $s->parse() now returns the number of parsed substvars. New method: $s->set_field_substvars(). =head2 Version 1.04 (dpkg 1.18.0) New method: $s->filter(). =head2 Version 1.03 (dpkg 1.17.11) New method: $s->set_as_auto(). =head2 Version 1.02 (dpkg 1.16.5) New argument: Accept a $binaryversion in $s->set_version_substvars(), passing a single argument is still supported. New method: $s->mark_as_used(). Deprecated method: $s->no_warn(), use $s->mark_as_used() instead. =head2 Version 1.01 (dpkg 1.16.4) New method: $s->set_as_used(). =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! ί��O! O! Changelog/Debian.pmnu �[��� # Copyright © 1996 Ian Jackson # Copyright © 2005 Frank Lichtenheld <frank@lichtenheld.de> # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2012-2017 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/>. =encoding utf8 =head1 NAME 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). The parser tries to ignore most cruft like # or /* */ style comments, RCS keywords, Vim modelines, Emacs local variables and stuff from older changelogs with other formats at the end of the file. NOTE: most of these are ignored silently currently, there is no parser error issued for them. This should become configurable in the future. =cut package Dpkg::Changelog::Debian; use strict; use warnings; our $VERSION = '1.00'; use Dpkg::Gettext; use Dpkg::File; use Dpkg::Changelog qw(:util); use Dpkg::Changelog::Entry::Debian qw(match_header match_trailer); use parent qw(Dpkg::Changelog); use constant { FIRST_HEADING => g_('first heading'), NEXT_OR_EOF => g_('next heading or end of file'), START_CHANGES => g_('start of change data'), CHANGES_OR_TRAILER => g_('more change data or trailer'), }; my $ancient_delimiter_re = qr{ ^ (?: # Ancient GNU style changelog entry with expanded date (?: \w+\s+ # Day of week (abbreviated) \w+\s+ # Month name (abbreviated) \d{1,2} # Day of month \Q \E \d{1,2}:\d{1,2}:\d{1,2}\s+ # Time [\w\s]* # Timezone \d{4} # Year ) \s+ (?:.*) # Maintainer name \s+ [<\(] (?:.*) # Maintainer email [\)>] | # Old GNU style changelog entry with expanded date (?: \w+\s+ # Day of week (abbreviated) \w+\s+ # Month name (abbreviated) \d{1,2},?\s* # Day of month \d{4} # Year ) \s+ (?:.*) # Maintainer name \s+ [<\(] (?:.*) # Maintainer email [\)>] | # Ancient changelog header w/o key=value options (?:\w[-+0-9a-z.]*) # Package name \Q \E \( (?:[^\(\) \t]+) # Package version \) \;? | # Ancient changelog header (?:[\w.+-]+) # Package name [- ] (?:\S+) # Package version \ Debian \ (?:\S+) # Package revision | Changes\ from\ version\ (?:.*)\ to\ (?:.*): | Changes\ for\ [\w.+-]+-[\w.+-]+:?\s*$ | Old\ Changelog:\s*$ | (?:\d+:)? \w[\w.+~-]*:? \s*$ ) }xi; =head1 METHODS =over 4 =item $count = $c->parse($fh, $description) 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. =cut sub parse { my ($self, $fh, $file) = @_; $file = $self->{reportfile} if exists $self->{reportfile}; $self->reset_parse_errors; $self->{data} = []; $self->set_unparsed_tail(undef); my $expect = FIRST_HEADING; my $entry = Dpkg::Changelog::Entry::Debian->new(); my @blanklines = (); my $unknowncounter = 1; # to make version unique, e.g. for using as id local $_; while (<$fh>) { chomp; if (match_header($_)) { unless ($expect eq FIRST_HEADING || $expect eq NEXT_OR_EOF) { $self->parse_error($file, $., sprintf(g_('found start of entry where expected %s'), $expect), "$_"); } unless ($entry->is_empty) { push @{$self->{data}}, $entry; $entry = Dpkg::Changelog::Entry::Debian->new(); last if $self->abort_early(); } $entry->set_part('header', $_); foreach my $error ($entry->parse_header()) { $self->parse_error($file, $., $error, $_); } $expect= START_CHANGES; @blanklines = (); } elsif (m/^(?:;;\s*)?Local variables:/io) { # Save any trailing Emacs variables at end of file. $self->set_unparsed_tail("$_\n" . (file_slurp($fh) // '')); last; } elsif (m/^vim:/io) { # 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) { next; # skip comments, even that's not supported } elsif (m{^/\*.*\*/}o) { next; # more comments } elsif (m/$ancient_delimiter_re/) { # save entries on old changelog format verbatim # we assume the rest of the file will be in old format once we # hit it for the first time $self->set_unparsed_tail("$_\n" . file_slurp($fh)); } elsif (m/^\S/) { $self->parse_error($file, $., g_('badly formatted heading line'), "$_"); } elsif (match_trailer($_)) { unless ($expect eq CHANGES_OR_TRAILER) { $self->parse_error($file, $., sprintf(g_('found trailer where expected %s'), $expect), "$_"); } $entry->set_part('trailer', $_); $entry->extend_part('blank_after_changes', [ @blanklines ]); @blanklines = (); foreach my $error ($entry->parse_trailer()) { $self->parse_error($file, $., $error, $_); } $expect = NEXT_OR_EOF; } elsif (m/^ \-\-/) { $self->parse_error($file, $., g_('badly formatted trailer line'), "$_"); } elsif (m/^\s{2,}(?:\S)/) { unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) { $self->parse_error($file, $., sprintf(g_('found change data' . ' where expected %s'), $expect), "$_"); if ($expect eq NEXT_OR_EOF and not $entry->is_empty) { # lets assume we have missed the actual header line push @{$self->{data}}, $entry; $entry = Dpkg::Changelog::Entry::Debian->new(); $entry->set_part('header', 'unknown (unknown' . ($unknowncounter++) . ') unknown; urgency=unknown'); } } # Keep raw changes $entry->extend_part('changes', [ @blanklines, $_ ]); @blanklines = (); $expect = CHANGES_OR_TRAILER; } elsif (!m/\S/) { if ($expect eq START_CHANGES) { $entry->extend_part('blank_after_header', $_); next; } elsif ($expect eq NEXT_OR_EOF) { $entry->extend_part('blank_after_trailer', $_); next; } elsif ($expect ne CHANGES_OR_TRAILER) { $self->parse_error($file, $., sprintf(g_('found blank line where expected %s'), $expect)); } push @blanklines, $_; } else { $self->parse_error($file, $., g_('unrecognized line'), "$_"); unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) { # lets assume change data if we expected it $entry->extend_part('changes', [ @blanklines, $_]); @blanklines = (); $expect = CHANGES_OR_TRAILER; } } } unless ($expect eq NEXT_OR_EOF) { $self->parse_error($file, $., sprintf(g_('found end of file where expected %s'), $expect)); } unless ($entry->is_empty) { push @{$self->{data}}, $entry; } return scalar @{$self->{data}}; } 1; __END__ =back =head1 CHANGES =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =head1 SEE ALSO Dpkg::Changelog =cut PK ! �0��D- D- Changelog/Entry/Debian.pmnu �[��� # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2012-2013 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::Changelog::Entry::Debian; use strict; use warnings; our $VERSION = '2.00'; our @EXPORT_OK = qw( match_header match_trailer find_closes ); use Exporter qw(import); use Time::Piece; use Dpkg::Gettext; use Dpkg::Control::Fields; use Dpkg::Control::Changelog; use Dpkg::Changelog::Entry; use Dpkg::Version; use parent qw(Dpkg::Changelog::Entry); =encoding utf8 =head1 NAME Dpkg::Changelog::Entry::Debian - represents a Debian changelog entry =head1 DESCRIPTION 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; # 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). my $regex_header = qr{ ^ (\w$name_chars*) # Package name \ \(([^\(\) \t]+)\) # Package version ((?:\s+$name_chars+)+) # Target distribution \; # Separator (.*?) # Key=Value options \s*$ # Trailing space }xi; # 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). my $regex_trailer = qr< ^ \ \-\- # Trailer marker \ (.*) # Maintainer name \ \<(.*)\> # Maintainer email (\ \ ?) # Blanks ( ((\w+)\,\s*)? # Day of week (abbreviated) ( \d{1,2}\s+ # Day of month (\w+)\s+ # Month name (abbreviated) \d{4}\s+ # Year \d{1,2}:\d\d:\d\d\s+[-+]\d{4} # ISO 8601 date ) ) \s*$ # Trailing space >xo; my %week_day = map { $_ => 1 } qw(Mon Tue Wed Thu Fri Sat Sun); my @month_abbrev = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec ); my %month_abbrev = map { $_ => 1 } @month_abbrev; my @month_name = qw( January February March April May June July August September October November December ); my %month_name = map { $month_name[$_] => $month_abbrev[$_] } 0 .. 11; =head1 METHODS =over 4 =item @items = $entry->get_change_items() Return a list of change items. Each item contains at least one line. A change line starting with an asterisk denotes the start of a new item. Any change line like "C<[ Raphaël Hertzog ]>" is treated like an item of its own even if it starts a set of items attributed to this person (the following line necessarily starts a new item). =cut sub get_change_items { my $self = shift; my (@items, @blanks, $item); foreach my $line (@{$self->get_part('changes')}) { if ($line =~ /^\s*\*/) { push @items, $item if defined $item; $item = "$line\n"; } elsif ($line =~ /^\s*\[\s[^\]]+\s\]\s*$/) { push @items, $item if defined $item; push @items, "$line\n"; $item = undef; @blanks = (); } elsif ($line =~ /^\s*$/) { push @blanks, "$line\n"; } else { if (defined $item) { $item .= "@blanks$line\n"; } else { $item = "$line\n"; } @blanks = (); } } push @items, $item if defined $item; return @items; } =item @errors = $entry->parse_header() =item @errors = $entry->parse_trailer() Return a list of errors. Each item in the list is an error message describing the problem. If the empty list is returned, no errors have been found. =cut sub parse_header { my $self = shift; my @errors; if (defined($self->{header}) and $self->{header} =~ $regex_header) { $self->{header_source} = $1; my $version = Dpkg::Version->new($2); my ($ok, $msg) = version_check($version); if ($ok) { $self->{header_version} = $version; } else { push @errors, sprintf(g_("version '%s' is invalid: %s"), $version, $msg); } @{$self->{header_dists}} = split ' ', $3; my $options = $4; $options =~ s/^\s+//; my $f = Dpkg::Control::Changelog->new(); foreach my $opt (split(/\s*,\s*/, $options)) { unless ($opt =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i) { push @errors, sprintf(g_("bad key-value after ';': '%s'"), $opt); next; } my ($k, $v) = (field_capitalize($1), $2); if (exists $f->{$k}) { push @errors, sprintf(g_('repeated key-value %s'), $k); } else { $f->{$k} = $v; } if ($k eq 'Urgency') { push @errors, sprintf(g_('badly formatted urgency value: %s'), $v) unless ($v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i); } elsif ($k eq 'Binary-Only') { push @errors, sprintf(g_('bad binary-only value: %s'), $v) unless ($v eq 'yes'); } elsif ($k =~ m/^X[BCS]+-/i) { } else { push @errors, sprintf(g_('unknown key-value %s'), $k); } } $self->{header_fields} = $f; } else { push @errors, g_("the header doesn't match the expected regex"); } return @errors; } sub parse_trailer { my $self = shift; my @errors; if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) { $self->{trailer_maintainer} = "$1 <$2>"; if ($3 ne ' ') { push @errors, g_('badly formatted trailer line'); } # Validate the week day. Date::Parse used to ignore it, but Time::Piece # is much more strict and it does not gracefully handle bogus values. if (defined $5 and not exists $week_day{$6}) { push @errors, sprintf(g_('ignoring invalid week day \'%s\''), $6); } # Ignore the week day ('%a, '), as we have validated it above. local $ENV{LC_ALL} = 'C'; eval { my $tp = Time::Piece->strptime($7, '%d %b %Y %T %z'); $self->{trailer_timepiece} = $tp; } or do { # Validate the month. Date::Parse used to accept both abbreviated # and full months, but Time::Piece strptime() implementation only # matches the abbreviated one with %b, which is what we want anyway. if (not exists $month_abbrev{$8}) { # We have to nest the conditionals because May is the same in # full and abbreviated forms! if (exists $month_name{$8}) { push @errors, sprintf(g_('uses full \'%s\' instead of abbreviated month name \'%s\''), $8, $month_name{$8}); } else { push @errors, sprintf(g_('invalid abbreviated month name \'%s\''), $8); } } push @errors, sprintf(g_("cannot parse non-conformant date '%s'"), $7); }; $self->{trailer_timestamp_date} = $4; } else { push @errors, g_("the trailer doesn't match the expected regex"); } return @errors; } =item $entry->normalize() Normalize the content. Strip whitespaces at end of lines, use a single empty line to separate each part. =cut sub normalize { my $self = shift; $self->SUPER::normalize(); #XXX: recreate header/trailer } =item $src = $entry->get_source() Return the name of the source package associated to the changelog entry. =cut sub get_source { my $self = shift; return $self->{header_source}; } =item $ver = $entry->get_version() Return the version associated to the changelog entry. =cut sub get_version { my $self = shift; return $self->{header_version}; } =item @dists = $entry->get_distributions() Return a list of target distributions for this version. =cut sub get_distributions { my $self = shift; if (defined $self->{header_dists}) { return @{$self->{header_dists}} if wantarray; return $self->{header_dists}[0]; } return; } =item $fields = $entry->get_optional_fields() Return a set of optional fields exposed by the changelog entry. It always returns a Dpkg::Control object (possibly empty though). =cut sub get_optional_fields { my $self = shift; my $f; if (defined $self->{header_fields}) { $f = $self->{header_fields}; } else { $f = Dpkg::Control::Changelog->new(); } my @closes = find_closes(join("\n", @{$self->{changes}})); if (@closes) { $f->{Closes} = join(' ', @closes); } return $f; } =item $urgency = $entry->get_urgency() Return the urgency of the associated upload. =cut sub get_urgency { my $self = shift; my $f = $self->get_optional_fields(); if (exists $f->{Urgency}) { $f->{Urgency} =~ s/\s.*$//; return lc($f->{Urgency}); } return; } =item $maint = $entry->get_maintainer() Return the string identifying the person who signed this changelog entry. =cut sub get_maintainer { my $self = shift; return $self->{trailer_maintainer}; } =item $time = $entry->get_timestamp() Return the timestamp of the changelog entry. =cut sub get_timestamp { my $self = shift; return $self->{trailer_timestamp_date}; } =item $time = $entry->get_timepiece() Return the timestamp of the changelog entry as a Time::Piece object. This function might return undef if there was no timestamp. =cut sub get_timepiece { my $self = shift; return $self->{trailer_timepiece}; } =back =head1 UTILITY FUNCTIONS =over 4 =item $bool = match_header($line) Checks if the line matches a valid changelog header line. =cut sub match_header { my $line = shift; return $line =~ /$regex_header/; } =item $bool = match_trailer($line) Checks if the line matches a valid changelog trailing line. =cut sub match_trailer { my $line = shift; return $line =~ /$regex_trailer/; } =item @closed_bugs = find_closes($changes) Takes one string as argument and finds "Closes: #123456, #654321" statements as supported by the Debian Archive software in it. Returns all closed bug numbers in an array. =cut sub find_closes { my $changes = shift; my %closes; while ($changes && ($changes =~ m{ closes:\s* (?:bug)?\#?\s?\d+ (?:,\s*(?:bug)?\#?\s?\d+)* }pigx)) { $closes{$_} = 1 foreach (${^MATCH} =~ /\#?\s?(\d+)/g); } my @closes = sort { $a <=> $b } keys %closes; return @closes; } =back =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(). =head2 Version 1.02 (dpkg 1.18.5) New methods: $entry->parse_header(), $entry->parse_trailer(). Deprecated methods: $entry->check_header(), $entry->check_trailer(). =head2 Version 1.01 (dpkg 1.17.2) New functions: match_header(), match_trailer() Deprecated variables: $regex_header, $regex_trailer =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! �2�4 4 Changelog/Entry.pmnu �[��� # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Changelog::Entry; use strict; use warnings; our $VERSION = '1.01'; use Carp; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Control::Changelog; use overload '""' => \&output, 'eq' => sub { defined($_[1]) and "$_[0]" eq "$_[1]" }, fallback => 1; =encoding utf8 =head1 NAME Dpkg::Changelog::Entry - represents a changelog entry =head1 DESCRIPTION This class represents a changelog entry. It is composed of a set of lines with specific purpose: a header line, changes lines, a trailer line. Blank lines can be between those kind of lines. =head1 METHODS =over 4 =item $entry = Dpkg::Changelog::Entry->new() Creates a new object. It doesn't represent a real changelog entry until one has been successfully parsed or built from scratch. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = { header => undef, changes => [], trailer => undef, blank_after_header => [], blank_after_changes => [], blank_after_trailer => [], }; bless $self, $class; return $self; } =item $str = $entry->output() =item "$entry" Get a string representation of the changelog entry. =item $entry->output($fh) Print the string representation of the changelog entry to a filehandle. =cut sub _format_output_block { my $lines = shift; return join('', map { $_ . "\n" } @{$lines}); } sub output { my ($self, $fh) = @_; my $str = ''; $str .= $self->{header} . "\n" if defined($self->{header}); $str .= _format_output_block($self->{blank_after_header}); $str .= _format_output_block($self->{changes}); $str .= _format_output_block($self->{blank_after_changes}); $str .= $self->{trailer} . "\n" if defined($self->{trailer}); $str .= _format_output_block($self->{blank_after_trailer}); print { $fh } $str if defined $fh; return $str; } =item $entry->get_part($part) Return either a string (for a single line) or an array ref (for multiple lines) corresponding to the requested part. $part can be "header, "changes", "trailer", "blank_after_header", "blank_after_changes", "blank_after_trailer". =cut sub get_part { my ($self, $part) = @_; croak "invalid part of changelog entry: $part" unless exists $self->{$part}; return $self->{$part}; } =item $entry->set_part($part, $value) Set the value of the corresponding part. $value can be a string or an array ref. =cut sub set_part { my ($self, $part, $value) = @_; croak "invalid part of changelog entry: $part" unless exists $self->{$part}; if (ref($self->{$part})) { if (ref($value)) { $self->{$part} = $value; } else { $self->{$part} = [ $value ]; } } else { $self->{$part} = $value; } } =item $entry->extend_part($part, $value) Concatenate $value at the end of the part. If the part is already a multi-line value, $value is added as a new line otherwise it's concatenated at the end of the current line. =cut sub extend_part { my ($self, $part, $value, @rest) = @_; croak "invalid part of changelog entry: $part" unless exists $self->{$part}; if (ref($self->{$part})) { if (ref($value)) { push @{$self->{$part}}, @$value; } else { push @{$self->{$part}}, $value; } } else { if (defined($self->{$part})) { if (ref($value)) { $self->{$part} = [ $self->{$part}, @$value ]; } else { $self->{$part} .= $value; } } else { $self->{$part} = $value; } } } =item $is_empty = $entry->is_empty() Returns 1 if the changelog entry doesn't contain anything at all. Returns 0 as soon as it contains something in any of its non-blank parts. =cut sub is_empty { my $self = shift; return !(defined($self->{header}) || defined($self->{trailer}) || scalar(@{$self->{changes}})); } =item $entry->normalize() Normalize the content. Strip whitespaces at end of lines, use a single empty line to separate each part. =cut sub normalize { my $self = shift; if (defined($self->{header})) { $self->{header} =~ s/\s+$//g; $self->{blank_after_header} = ['']; } else { $self->{blank_after_header} = []; } if (scalar(@{$self->{changes}})) { s/\s+$//g foreach @{$self->{changes}}; $self->{blank_after_changes} = ['']; } else { $self->{blank_after_changes} = []; } if (defined($self->{trailer})) { $self->{trailer} =~ s/\s+$//g; $self->{blank_after_trailer} = ['']; } else { $self->{blank_after_trailer} = []; } } =item $src = $entry->get_source() Return the name of the source package associated to the changelog entry. =cut sub get_source { return; } =item $ver = $entry->get_version() Return the version associated to the changelog entry. =cut sub get_version { return; } =item @dists = $entry->get_distributions() Return a list of target distributions for this version. =cut sub get_distributions { return; } =item $fields = $entry->get_optional_fields() Return a set of optional fields exposed by the changelog entry. It always returns a Dpkg::Control object (possibly empty though). =cut sub get_optional_fields { return Dpkg::Control::Changelog->new(); } =item $urgency = $entry->get_urgency() Return the urgency of the associated upload. =cut sub get_urgency { return; } =item $maint = $entry->get_maintainer() Return the string identifying the person who signed this changelog entry. =cut sub get_maintainer { return; } =item $time = $entry->get_timestamp() Return the timestamp of the changelog entry. =cut sub get_timestamp { return; } =item $time = $entry->get_timepiece() Return the timestamp of the changelog entry as a Time::Piece object. This function might return undef if there was no timestamp. =cut sub get_timepiece { return; } =item $str = $entry->get_dpkg_changes() Returns a string that is suitable for usage in a C<Changes> field in the output format of C<dpkg-parsechangelog>. =cut sub get_dpkg_changes { my $self = shift; my $header = $self->get_part('header') // ''; $header =~ s/\s+$//; return "\n$header\n\n" . join("\n", @{$self->get_part('changes')}); } =back =head1 CHANGES =head2 Version 1.01 (dpkg 1.18.8) New method: $entry->get_timepiece(). =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! ڀ@�� � Changelog/Parse.pmnu �[��� # Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de> # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2010, 2012-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/>. =encoding utf8 =head1 NAME Dpkg::Changelog::Parse - generic changelog parser for dpkg-parsechangelog =head1 DESCRIPTION This module provides a set of functions which reproduce all the features of dpkg-parsechangelog. =cut package Dpkg::Changelog::Parse; use strict; use warnings; our $VERSION = '2.01'; our @EXPORT = qw( changelog_parse ); use Exporter qw(import); use List::Util qw(none); use Dpkg (); use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Control::Changelog; sub _changelog_detect_format { my $file = shift; my $format = 'debian'; # Extract the format from the changelog file if possible if ($file ne '-') { local $_; 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; } return $format; } =head1 FUNCTIONS =over 4 =item $fields = changelog_parse(%opt) This function will parse a changelog. In list context, it returns as many Dpkg::Control objects as the parser did create. In scalar context, it will return only the first one. If the parser did not return any data, it will return an empty list in list context or undef on scalar context. If the parser failed, it will die. Any parse errors will be printed as warnings on standard error, but this can be disabled by passing $opt{verbose} to 0. The changelog file that is parsed is F<debian/changelog> by default but it can be overridden with $opt{file}. The changelog name used in output messages can be specified with $opt{label}, otherwise it will default to $opt{file}. The default output format is "dpkg" but it can be overridden with $opt{format}. The parsing itself is done by a parser module (searched in the standard perl library directories. That module is named according to the format that it is able to parse, with the name capitalized. By default it is either Dpkg::Changelog::Debian (from the "debian" format) or the format name looked up in the 40 last lines of the changelog itself (extracted with this perl regular expression "\schangelog-format:\s+([0-9a-z]+)\W"). But it can be overridden with $opt{changelogformat}. If $opt{compression} is false, the file will be loaded without compression support, otherwise by default compression support is disabled if the file is the default. All the other keys in %opt are forwarded to the parser module constructor. =cut sub changelog_parse { my (%options) = @_; $options{verbose} //= 1; $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 reverse all); $options{all} = 1 if exists $options{all}; if (none { defined $options{$_} } @range_opts) { $options{count} = 1; } my $range; foreach my $opt (@range_opts) { $range->{$opt} = $options{$opt} if exists $options{$opt}; } # Find the right changelog parser. my $format = ucfirst lc $options{changelogformat}; my $changes; eval qq{ pop \@INC if \$INC[-1] eq '.'; require Dpkg::Changelog::$format; \$changes = Dpkg::Changelog::$format->new(); }; error(g_('changelog format %s is unknown: %s'), $format, $@) if $@; error(g_('changelog format %s is not a Dpkg::Changelog class'), $format) unless $changes->isa('Dpkg::Changelog'); $changes->set_options(reportfile => $options{label}, verbose => $options{verbose}, range => $range); # Load and parse the changelog. $changes->load($options{file}, compression => $options{compression}) or error(g_('fatal error occurred while parsing %s'), $options{file}); # Get the output into several Dpkg::Control objects. my @res; if ($options{format} eq 'dpkg') { push @res, $changes->format_range('dpkg', $range); } elsif ($options{format} eq 'rfc822') { push @res, $changes->format_range('rfc822', $range); } else { error(g_('unknown output format %s'), $options{format}); } if (wantarray) { return @res; } else { return $res[0] if @res; return; } } =back =head1 CHANGES =head2 Version 2.01 (dpkg 1.20.6) New option: 'verbose' in changelog_parse(). =head2 Version 2.00 (dpkg 1.20.0) Remove functions: changelog_parse_debian(), changelog_parse_plugin(). Remove warnings: For options 'forceplugin', 'libdir'. =head2 Version 1.03 (dpkg 1.19.0) New option: 'compression' in changelog_parse(). =head2 Version 1.02 (dpkg 1.18.8) Deprecated functions: changelog_parse_debian(), changelog_parse_plugin(). Obsolete options: forceplugin, libdir. =head2 Version 1.01 (dpkg 1.18.2) New functions: changelog_parse_debian(), changelog_parse_plugin(). =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! ��m� � Gettext.pmnu �[��� # Copied from /usr/share/perl5/Debconf/Gettext.pm # # Copyright © 2000 Joey Hess <joeyh@debian.org> # Copyright © 2007, 2009-2010, 2012-2017 Guillem Jover <guillem@debian.org> # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # 1. Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF # SUCH DAMAGE. package Dpkg::Gettext; use strict; use warnings; use feature qw(state); our $VERSION = '2.00'; our @EXPORT = qw( textdomain ngettext g_ P_ N_ ); use Exporter qw(import); =encoding utf8 =head1 NAME Dpkg::Gettext - convenience wrapper around Locale::gettext =head1 DESCRIPTION The Dpkg::Gettext module is a convenience wrapper over the Locale::gettext module, to guarantee we always have working gettext functions, and to add some commonly used aliases. =head1 ENVIRONMENT =over 4 =item DPKG_NLS When set to 0, this environment variable will disable the National Language Support in all Dpkg modules. =back =head1 VARIABLES =over 4 =item $Dpkg::Gettext::DEFAULT_TEXT_DOMAIN Specifies the default text domain name to be used with the short function aliases. This is intended to be used by the Dpkg modules, so that they can produce localized messages even when the calling program has set the current domain with textdomain(). If you would like to use the aliases for your own modules, you might want to set this variable to undef, or to another domain, but then the Dpkg modules will not produce localized messages. =back =cut our $DEFAULT_TEXT_DOMAIN = 'dpkg-dev'; =head1 FUNCTIONS =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 locale. If dgettext() is not available, simply returns $msgid. =item $trans = C_($msgctxt, $msgid) Calls dgettext() on the $msgid and returns its translation for the specific $msgctxt supplied. If dgettext() is not available, simply returns $msgid. =item $trans = P_($msgid, $msgid_plural, $n) Calls dngettext(), returning the correct translation for the plural form dependent on $n. If dngettext() is not available, returns $msgid if $n is 1 or $msgid_plural otherwise. =cut use constant GETTEXT_CONTEXT_GLUE => "\004"; BEGIN { my $use_gettext = $ENV{DPKG_NLS} // 1; if ($use_gettext) { eval q{ pop @INC if $INC[-1] eq '.'; use Locale::gettext; }; $use_gettext = not $@; } if (not $use_gettext) { *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; } else { return $msgid_plural; } }; *C_ = sub { my ($msgctxt, $msgid) = @_; return $msgid; }; *P_ = sub { return ngettext(@_); }; } else { *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, @_); }; } } =item $msgid = N_($msgid) A pseudo function that servers as a marked for automated extraction of messages, but does not call gettext(). The run-time translation is done at a different place in the code. =back =cut sub N_ { my $msgid = shift; return $msgid; } =head1 CHANGES =head2 Version 2.00 (dpkg 1.20.0) Remove function: _g(). =head2 Version 1.03 (dpkg 1.19.0) New envvar: Add support for new B<DPKG_NLS> environment variable. =head2 Version 1.02 (dpkg 1.18.3) New function: N_(). =head2 Version 1.01 (dpkg 1.18.0) Now the short aliases (g_ and P_) will call domain aware functions with $DEFAULT_TEXT_DOMAIN. New functions: g_(), C_(). Deprecated function: _g(). =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! T��� Lock.pmnu �[��� # Copyright © 2011 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2012 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::Lock; use strict; use warnings; our $VERSION = '0.01'; our @EXPORT = qw( file_lock ); use Exporter qw(import); use Fcntl qw(:flock); use Dpkg::Gettext; use Dpkg::ErrorHandling; sub file_lock($$) { my ($fh, $filename) = @_; # A strict dependency on libfile-fcntllock-perl being it an XS module, # and dpkg-dev indirectly making use of it, makes building new perl # package which bump the perl ABI impossible as these packages cannot # be installed alongside. eval q{ pop @INC if $INC[-1] eq '.'; use File::FcntlLock; }; if ($@) { # On Linux systems the flock() locks get converted to file-range # locks on NFS mounts. if ($^O ne 'linux') { warning(g_('File::FcntlLock not available; using flock which is not NFS-safe')); } flock($fh, LOCK_EX) or syserr(g_('failed to get a write lock on %s'), $filename); } else { eval q{ my $fs = File::FcntlLock->new(l_type => F_WRLCK); $fs->lock($fh, F_SETLKW) or syserr(g_('failed to get a write lock on %s'), $filename); } } } 1; PK ! ��Vv v Control/Tests/Entry.pmnu �[��� # Copyright © 2016 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::Control::Tests::Entry; use strict; use warnings; our $VERSION = '1.00'; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Control; use parent qw(Dpkg::Control); =encoding utf8 =head1 NAME Dpkg::Control::Tests::Entry - represents a test suite entry =head1 DESCRIPTION This class represents a test suite entry. =head1 METHODS All the methods of Dpkg::Control are available. Those listed below are either new or overridden with a different behavior. =over 4 =item $entry = Dpkg::Control::Tests::Entry->new() Creates a new object. It does not represent a real control test entry until one has been successfully parsed or built from scratch. =cut sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; my $self = Dpkg::Control->new(type => CTRL_TESTS, %opts); bless $self, $class; return $self; } =item $entry->parse($fh, $desc) Parse a control test entry from a filehandle. When called multiple times, the parsed fields are accumulated. Returns true if parsing was a success. =cut sub parse { my ($self, $fh, $desc) = @_; return if not $self->SUPER::parse($fh, $desc); if (not exists $self->{'Tests'} and not exists $self->{'Test-Command'}) { $self->parse_error($desc, g_('block lacks either %s or %s fields'), 'Tests', 'Test-Command'); } return 1; } =back =head1 CHANGES =head2 Version 1.00 (dpkg 1.18.8) Mark the module as public. =cut 1; PK ! *&�� Control/Info.pmnu �[��� # Copyright © 2007-2010 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2009, 2012-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::Control::Info; use strict; use warnings; our $VERSION = '1.01'; use Dpkg::Control; use Dpkg::ErrorHandling; use Dpkg::Gettext; use parent qw(Dpkg::Interface::Storable); use overload '@{}' => sub { return [ $_[0]->{source}, @{$_[0]->{packages}} ] }; =encoding utf8 =head1 NAME Dpkg::Control::Info - parse files like debian/control =head1 DESCRIPTION It provides a class to access data of files that follow the same syntax as F<debian/control>. =head1 METHODS =over 4 =item $c = Dpkg::Control::Info->new(%opts) Create a new Dpkg::Control::Info object. Loads the file from the filename option, if no option is specified filename defaults to F<debian/control>. If a scalar is passed instead, it will be used as the filename. If filename is "-", it parses the standard input. If filename is undef no loading will be performed. =cut sub new { my ($this, @args) = @_; my $class = ref($this) || $this; my $self = { source => undef, packages => [], }; bless $self, $class; my %opts; if (scalar @args == 0) { $opts{filename} = 'debian/control'; } elsif (scalar @args == 1) { $opts{filename} = $args[0]; } else { %opts = @args; } $self->load($opts{filename}) if $opts{filename}; return $self; } =item $c->reset() Resets what got read. =cut sub reset { my $self = shift; $self->{source} = undef; $self->{packages} = []; } =item $c->parse($fh, $description) Parse a control file from the given filehandle. Exits in case of errors. $description is used to describe the filehandle, ideally it's a filename or a description of where the data comes from. It is used in error messages. The data in the object is reset before parsing new control files. =cut sub parse { my ($self, $fh, $desc) = @_; $self->reset(); my $cdata = Dpkg::Control->new(type => CTRL_INFO_SRC); return if not $cdata->parse($fh, $desc); $self->{source} = $cdata; unless (exists $cdata->{Source}) { $cdata->parse_error($desc, g_('first block lacks a Source field')); } while (1) { $cdata = Dpkg::Control->new(type => CTRL_INFO_PKG); last if not $cdata->parse($fh, $desc); push @{$self->{packages}}, $cdata; unless (exists $cdata->{Package}) { $cdata->parse_error($desc, g_("block lacks the '%s' field"), 'Package'); } unless (exists $cdata->{Architecture}) { $cdata->parse_error($desc, g_("block lacks the '%s' field"), 'Architecture'); } } } =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() Returns a Dpkg::Control object containing the fields concerning the source package. =cut sub get_source { my $self = shift; return $self->{source}; } =item $c->get_pkg_by_idx($idx) Returns a Dpkg::Control object containing the fields concerning the binary package numbered $idx (starting at 1). =cut sub get_pkg_by_idx { my ($self, $idx) = @_; return $self->{packages}[--$idx]; } =item $c->get_pkg_by_name($name) Returns a Dpkg::Control object containing the fields concerning the binary package named $name. =cut sub get_pkg_by_name { my ($self, $name) = @_; foreach my $pkg (@{$self->{packages}}) { return $pkg if ($pkg->{Package} eq $name); } return; } =item $c->get_packages() Returns a list containing the Dpkg::Control objects for all binary packages. =cut sub get_packages { my $self = shift; return @{$self->{packages}}; } =item $str = $c->output([$fh]) Return the content info into a string. If $fh is specified print it into the filehandle. =cut sub output { my ($self, $fh) = @_; my $str; $str .= $self->{source}->output($fh); foreach my $pkg (@{$self->{packages}}) { print { $fh } "\n" if defined $fh; $str .= "\n" . $pkg->output($fh); } return $str; } =item "$c" Return a string representation of the content. =item @{$c} Return a list of Dpkg::Control objects, the first one is corresponding to source information and the following ones are the binary packages information. =back =head1 CHANGES =head2 Version 1.01 (dpkg 1.18.0) New argument: The $c->new() constructor accepts an %opts argument. =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! f��� � Control/Hash.pmnu �[��� # Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Control::Hash; use strict; use warnings; our $VERSION = '1.00'; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Control::Fields; # Force execution of vendor hook. use parent qw(Dpkg::Control::HashCore); =encoding utf8 =head1 NAME Dpkg::Control::Hash - parse and manipulate a block of RFC822-like fields =head1 DESCRIPTION This module is just like Dpkg::Control::HashCore, with vendor-specific field knowledge. =head1 CHANGES =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! ��� � Control/Changelog.pmnu �[��� # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Control::Changelog; use strict; use warnings; our $VERSION = '1.00'; use Dpkg::Control; use parent qw(Dpkg::Control); =encoding utf8 =head1 NAME Dpkg::Control::Changelog - represent info fields output by dpkg-parsechangelog =head1 DESCRIPTION This class derives directly from Dpkg::Control with the type CTRL_CHANGELOG. =head1 METHODS =over 4 =item $c = Dpkg::Control::Changelog->new() Create a new empty set of changelog related fields. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = Dpkg::Control->new(type => CTRL_CHANGELOG, @_); return bless $self, $class; } =back =head1 CHANGES =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! ��/� � Control/Tests.pmnu �[��� # Copyright © 2016 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::Control::Tests; use strict; use warnings; our $VERSION = '1.00'; use Dpkg::Control; use Dpkg::Control::Tests::Entry; use Dpkg::Index; use parent qw(Dpkg::Index); =encoding utf8 =head1 NAME Dpkg::Control::Tests - parse files like debian/tests/control =head1 DESCRIPTION It provides a class to access data of files that follow the same syntax as F<debian/tests/control>. =head1 METHODS All the methods of Dpkg::Index are available. Those listed below are either new or overridden with a different behavior. =over 4 =item $c = Dpkg::Control::Tests->new(%opts) Create a new Dpkg::Control::Tests object, which inherits from Dpkg::Index. =cut sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; my $self = Dpkg::Index->new(type => CTRL_TESTS, %opts); return bless $self, $class; } =item $item = $tests->new_item() Creates a new item. =cut sub new_item { my $self = shift; return Dpkg::Control::Tests::Entry->new(); } =back =head1 CHANGES =head2 Version 1.00 (dpkg 1.18.8) Mark the module as public. =cut 1; PK ! ���n�s �s Control/FieldsCore.pmnu �[��� # Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Control::FieldsCore; use strict; use warnings; our $VERSION = '1.01'; our @EXPORT = qw( field_capitalize field_is_official field_is_allowed_in field_transfer_single field_transfer_all field_parse_binary_source field_list_src_dep field_list_pkg_dep field_get_dep_type field_get_sep_type field_ordered_list field_register field_insert_after field_insert_before FIELD_SEP_UNKNOWN FIELD_SEP_SPACE FIELD_SEP_COMMA FIELD_SEP_LINE ); use Exporter qw(import); use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Control::Types; use constant { ALL_PKG => CTRL_INFO_PKG | CTRL_INDEX_PKG | CTRL_PKG_DEB | CTRL_FILE_STATUS, ALL_SRC => CTRL_INFO_SRC | CTRL_INDEX_SRC | CTRL_PKG_SRC, ALL_CHANGES => CTRL_FILE_CHANGES | CTRL_CHANGELOG, ALL_COPYRIGHT => CTRL_COPYRIGHT_HEADER | CTRL_COPYRIGHT_FILES | CTRL_COPYRIGHT_LICENSE, }; use constant { FIELD_SEP_UNKNOWN => 0, FIELD_SEP_SPACE => 1, FIELD_SEP_COMMA => 2, FIELD_SEP_LINE => 4, }; # The canonical list of fields # Note that fields used only in dpkg's available file are not listed # Deprecated fields of dpkg's status file are also not listed our %FIELDS = ( 'architecture' => { name => 'Architecture', allowed => (ALL_PKG | ALL_SRC | CTRL_FILE_BUILDINFO | CTRL_FILE_CHANGES) & (~CTRL_INFO_SRC), separator => FIELD_SEP_SPACE, }, 'architectures' => { name => 'Architectures', allowed => CTRL_REPO_RELEASE, separator => FIELD_SEP_SPACE, }, 'auto-built-package' => { name => 'Auto-Built-Package', allowed => ALL_PKG & ~CTRL_INFO_PKG, separator => FIELD_SEP_SPACE, }, 'binary' => { name => 'Binary', allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_BUILDINFO | CTRL_FILE_CHANGES, # XXX: This field values are separated either by space or comma # depending on the context. separator => FIELD_SEP_SPACE | FIELD_SEP_COMMA, }, 'binary-only' => { name => 'Binary-Only', allowed => ALL_CHANGES, }, 'binary-only-changes' => { name => 'Binary-Only-Changes', allowed => CTRL_FILE_BUILDINFO, }, 'breaks' => { name => 'Breaks', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 7, }, 'bugs' => { name => 'Bugs', allowed => (ALL_PKG | CTRL_INFO_SRC | CTRL_FILE_VENDOR) & (~CTRL_INFO_PKG), }, 'build-architecture' => { name => 'Build-Architecture', allowed => CTRL_FILE_BUILDINFO, }, 'build-conflicts' => { name => 'Build-Conflicts', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 4, }, 'build-conflicts-arch' => { name => 'Build-Conflicts-Arch', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 5, }, 'build-conflicts-indep' => { name => 'Build-Conflicts-Indep', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 6, }, 'build-date' => { name => 'Build-Date', allowed => CTRL_FILE_BUILDINFO, }, 'build-depends' => { name => 'Build-Depends', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 1, }, 'build-depends-arch' => { name => 'Build-Depends-Arch', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 2, }, 'build-depends-indep' => { name => 'Build-Depends-Indep', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 3, }, 'build-essential' => { name => 'Build-Essential', allowed => ALL_PKG, }, 'build-kernel-version' => { name => 'Build-Kernel-Version', allowed => CTRL_FILE_BUILDINFO, }, 'build-origin' => { name => 'Build-Origin', allowed => CTRL_FILE_BUILDINFO, }, 'build-path' => { name => 'Build-Path', allowed => CTRL_FILE_BUILDINFO, }, 'build-profiles' => { name => 'Build-Profiles', 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, separator => FIELD_SEP_SPACE, }, 'built-using' => { name => 'Built-Using', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 10, }, 'changed-by' => { name => 'Changed-By', allowed => CTRL_FILE_CHANGES, }, 'changelogs' => { name => 'Changelogs', allowed => CTRL_REPO_RELEASE, }, 'changes' => { name => 'Changes', allowed => ALL_CHANGES, }, 'checksums-md5' => { name => 'Checksums-Md5', allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_CHANGES | CTRL_FILE_BUILDINFO, }, 'checksums-sha1' => { name => 'Checksums-Sha1', allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_CHANGES | CTRL_FILE_BUILDINFO, }, 'checksums-sha256' => { name => 'Checksums-Sha256', allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_CHANGES | CTRL_FILE_BUILDINFO, }, 'classes' => { name => 'Classes', allowed => CTRL_TESTS, separator => FIELD_SEP_COMMA, }, 'closes' => { name => 'Closes', allowed => ALL_CHANGES, separator => FIELD_SEP_SPACE, }, 'codename' => { name => 'Codename', allowed => CTRL_REPO_RELEASE, }, 'comment' => { name => 'Comment', allowed => ALL_COPYRIGHT, }, 'components' => { name => 'Components', allowed => CTRL_REPO_RELEASE, separator => FIELD_SEP_SPACE, }, 'conffiles' => { name => 'Conffiles', allowed => CTRL_FILE_STATUS, separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, }, 'config-version' => { name => 'Config-Version', allowed => CTRL_FILE_STATUS, }, 'conflicts' => { name => 'Conflicts', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 6, }, 'copyright' => { name => 'Copyright', allowed => CTRL_COPYRIGHT_HEADER | CTRL_COPYRIGHT_FILES, }, 'date' => { name => 'Date', allowed => ALL_CHANGES | CTRL_REPO_RELEASE, }, 'depends' => { name => 'Depends', allowed => ALL_PKG | CTRL_TESTS, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 2, }, 'description' => { name => 'Description', allowed => ALL_SRC | ALL_PKG | CTRL_FILE_CHANGES | CTRL_REPO_RELEASE, }, 'disclaimer' => { name => 'Disclaimer', allowed => CTRL_COPYRIGHT_HEADER, }, 'directory' => { name => 'Directory', allowed => CTRL_INDEX_SRC, }, 'distribution' => { name => 'Distribution', allowed => ALL_CHANGES, }, 'enhances' => { name => 'Enhances', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 5, }, 'environment' => { name => 'Environment', allowed => CTRL_FILE_BUILDINFO, separator => FIELD_SEP_LINE, }, 'essential' => { name => 'Essential', allowed => ALL_PKG, }, 'features' => { name => 'Features', allowed => CTRL_TESTS, separator => FIELD_SEP_SPACE, }, 'filename' => { name => 'Filename', allowed => CTRL_INDEX_PKG, separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, }, 'files' => { name => 'Files', allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_CHANGES | CTRL_COPYRIGHT_FILES, separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, }, 'format' => { name => 'Format', allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_CHANGES | CTRL_COPYRIGHT_HEADER | CTRL_FILE_BUILDINFO, }, 'homepage' => { name => 'Homepage', allowed => ALL_SRC | ALL_PKG, }, 'installed-build-depends' => { name => 'Installed-Build-Depends', allowed => CTRL_FILE_BUILDINFO, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 11, }, 'installed-size' => { name => 'Installed-Size', allowed => ALL_PKG & ~CTRL_INFO_PKG, }, 'installer-menu-item' => { name => 'Installer-Menu-Item', allowed => ALL_PKG, }, 'kernel-version' => { name => 'Kernel-Version', allowed => ALL_PKG, }, 'label' => { name => 'Label', allowed => CTRL_REPO_RELEASE, }, 'license' => { name => 'License', allowed => ALL_COPYRIGHT, }, 'origin' => { name => 'Origin', allowed => (ALL_PKG | ALL_SRC | CTRL_REPO_RELEASE) & (~CTRL_INFO_PKG), }, 'maintainer' => { name => 'Maintainer', allowed => CTRL_PKG_DEB| CTRL_INDEX_PKG | CTRL_FILE_STATUS | ALL_SRC | ALL_CHANGES, }, 'md5sum' => { # XXX: Wrong capitalization due to historical reasons. name => 'MD5sum', allowed => CTRL_INDEX_PKG | CTRL_REPO_RELEASE, separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, }, 'multi-arch' => { name => 'Multi-Arch', allowed => ALL_PKG, }, 'package' => { name => 'Package', allowed => ALL_PKG | CTRL_INDEX_SRC, }, 'package-list' => { name => 'Package-List', allowed => ALL_SRC & ~CTRL_INFO_SRC, separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, }, 'package-type' => { name => 'Package-Type', allowed => ALL_PKG, }, 'parent' => { name => 'Parent', allowed => CTRL_FILE_VENDOR, }, 'pre-depends' => { name => 'Pre-Depends', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 1, }, 'priority' => { name => 'Priority', allowed => CTRL_INFO_SRC | CTRL_INDEX_SRC | ALL_PKG, }, 'protected' => { name => 'Protected', allowed => ALL_PKG, }, 'provides' => { name => 'Provides', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 9, }, 'recommends' => { name => 'Recommends', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 3, }, 'replaces' => { name => 'Replaces', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 8, }, 'restrictions' => { name => 'Restrictions', allowed => CTRL_TESTS, separator => FIELD_SEP_SPACE, }, 'rules-requires-root' => { name => 'Rules-Requires-Root', allowed => CTRL_INFO_SRC, separator => FIELD_SEP_SPACE, }, 'section' => { name => 'Section', allowed => CTRL_INFO_SRC | CTRL_INDEX_SRC | ALL_PKG, }, 'sha1' => { # XXX: Wrong capitalization due to historical reasons. name => 'SHA1', allowed => CTRL_INDEX_PKG | CTRL_REPO_RELEASE, separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, }, 'sha256' => { # XXX: Wrong capitalization due to historical reasons. name => 'SHA256', allowed => CTRL_INDEX_PKG | CTRL_REPO_RELEASE, separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, }, 'size' => { name => 'Size', allowed => CTRL_INDEX_PKG, separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, }, 'source' => { name => 'Source', allowed => (ALL_PKG | ALL_SRC | ALL_CHANGES | CTRL_COPYRIGHT_HEADER | CTRL_FILE_BUILDINFO) & (~(CTRL_INDEX_SRC | CTRL_INFO_PKG)), }, 'standards-version' => { name => 'Standards-Version', allowed => ALL_SRC, }, 'status' => { name => 'Status', allowed => CTRL_FILE_STATUS, separator => FIELD_SEP_SPACE, }, 'subarchitecture' => { name => 'Subarchitecture', allowed => ALL_PKG, }, 'suite' => { name => 'Suite', allowed => CTRL_REPO_RELEASE, }, 'suggests' => { name => 'Suggests', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 4, }, 'tag' => { name => 'Tag', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, }, 'task' => { name => 'Task', allowed => ALL_PKG, }, 'test-command' => { name => 'Test-Command', allowed => CTRL_TESTS, }, 'tests' => { name => 'Tests', allowed => CTRL_TESTS, separator => FIELD_SEP_SPACE, }, 'tests-directory' => { name => 'Tests-Directory', allowed => CTRL_TESTS, }, 'testsuite' => { name => 'Testsuite', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, }, 'testsuite-triggers' => { name => 'Testsuite-Triggers', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, }, 'timestamp' => { name => 'Timestamp', allowed => CTRL_CHANGELOG, }, 'triggers-awaited' => { name => 'Triggers-Awaited', allowed => CTRL_FILE_STATUS, separator => FIELD_SEP_SPACE, }, 'triggers-pending' => { name => 'Triggers-Pending', allowed => CTRL_FILE_STATUS, separator => FIELD_SEP_SPACE, }, 'uploaders' => { name => 'Uploaders', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, }, 'upstream-name' => { name => 'Upstream-Name', allowed => CTRL_COPYRIGHT_HEADER, }, 'upstream-contact' => { name => 'Upstream-Contact', allowed => CTRL_COPYRIGHT_HEADER, }, 'urgency' => { name => 'Urgency', allowed => ALL_CHANGES, }, 'valid-until' => { name => 'Valid-Until', allowed => CTRL_REPO_RELEASE, }, 'vcs-browser' => { name => 'Vcs-Browser', allowed => ALL_SRC, }, 'vcs-arch' => { name => 'Vcs-Arch', allowed => ALL_SRC, }, 'vcs-bzr' => { name => 'Vcs-Bzr', allowed => ALL_SRC, }, 'vcs-cvs' => { name => 'Vcs-Cvs', allowed => ALL_SRC, }, 'vcs-darcs' => { name => 'Vcs-Darcs', allowed => ALL_SRC, }, 'vcs-git' => { name => 'Vcs-Git', allowed => ALL_SRC, }, 'vcs-hg' => { name => 'Vcs-Hg', allowed => ALL_SRC, }, 'vcs-mtn' => { name => 'Vcs-Mtn', allowed => ALL_SRC, }, 'vcs-svn' => { name => 'Vcs-Svn', allowed => ALL_SRC, }, 'vendor' => { name => 'Vendor', allowed => CTRL_FILE_VENDOR, }, 'vendor-url' => { name => 'Vendor-Url', allowed => CTRL_FILE_VENDOR, }, 'version' => { name => 'Version', allowed => (ALL_PKG | ALL_SRC | CTRL_FILE_BUILDINFO | ALL_CHANGES) & (~(CTRL_INFO_SRC | CTRL_INFO_PKG)), }, ); my @src_dep_fields = qw(build-depends build-depends-arch build-depends-indep build-conflicts build-conflicts-arch build-conflicts-indep); my @bin_dep_fields = qw(pre-depends depends recommends suggests enhances conflicts breaks replaces provides built-using); my @src_checksums_fields = qw(checksums-md5 checksums-sha1 checksums-sha256); my @bin_checksums_fields = qw(md5sum sha1 sha256); our %FIELD_ORDER = ( CTRL_PKG_DEB() => [ qw(package package-type source version built-using kernel-version built-for-profiles auto-built-package architecture subarchitecture installer-menu-item build-essential essential protected origin bugs maintainer installed-size), @bin_dep_fields, qw(section priority multi-arch homepage description tag task) ], CTRL_INDEX_PKG() => [ qw(package package-type source version built-using kernel-version built-for-profiles auto-built-package architecture subarchitecture installer-menu-item build-essential essential protected origin bugs maintainer installed-size), @bin_dep_fields, qw(filename size), @bin_checksums_fields, qw(section priority multi-arch homepage description tag task) ], CTRL_PKG_SRC() => [ qw(format source binary architecture version origin maintainer uploaders homepage description standards-version vcs-browser vcs-arch vcs-bzr vcs-cvs vcs-darcs vcs-git vcs-hg vcs-mtn vcs-svn testsuite testsuite-triggers), @src_dep_fields, qw(package-list), @src_checksums_fields, qw(files) ], CTRL_INDEX_SRC() => [ qw(format package binary architecture version priority section origin maintainer uploaders homepage description standards-version vcs-browser vcs-arch vcs-bzr vcs-cvs vcs-darcs vcs-git vcs-hg vcs-mtn vcs-svn testsuite testsuite-triggers), @src_dep_fields, qw(package-list directory), @src_checksums_fields, qw(files) ], CTRL_FILE_BUILDINFO() => [ qw(format source binary architecture version binary-only-changes), @src_checksums_fields, qw(build-origin build-architecture build-kernel-version build-date build-path build-tainted-by installed-build-depends environment), ], CTRL_FILE_CHANGES() => [ qw(format date source binary binary-only built-for-profiles architecture version distribution urgency maintainer changed-by description closes changes), @src_checksums_fields, qw(files) ], CTRL_CHANGELOG() => [ qw(source binary-only version distribution urgency maintainer timestamp date closes changes) ], CTRL_FILE_STATUS() => [ # Same as fieldinfos in lib/dpkg/parse.c qw(package essential protected status priority section installed-size origin maintainer bugs architecture multi-arch source version config-version replaces provides depends pre-depends recommends suggests breaks conflicts enhances conffiles description triggers-pending triggers-awaited), # These are allowed here, but not tracked by lib/dpkg/parse.c. qw(auto-built-package build-essential built-for-profiles built-using homepage installer-menu-item kernel-version package-type subarchitecture tag task) ], CTRL_REPO_RELEASE() => [ qw(origin label suite codename changelogs date valid-until architectures components description), @bin_checksums_fields ], CTRL_COPYRIGHT_HEADER() => [ qw(format upstream-name upstream-contact source disclaimer comment license copyright) ], CTRL_COPYRIGHT_FILES() => [ qw(files copyright license comment) ], CTRL_COPYRIGHT_LICENSE() => [ qw(license comment) ], ); =encoding utf8 =head1 NAME Dpkg::Control::FieldsCore - manage (list of official) control fields =head1 DESCRIPTION The modules contains a list of fieldnames with associated meta-data explaining in which type of control information they are allowed. The types are the CTRL_* constants exported by Dpkg::Control. =head1 FUNCTIONS =over 4 =item $f = field_capitalize($field_name) Returns the field name properly capitalized. All characters are lowercase, except the first of each word (words are separated by a hyphen in field names). =cut sub field_capitalize($) { my $field = lc(shift); # Use known fields first. return $FIELDS{$field}{name} if exists $FIELDS{$field}; # Generic case return join '-', map { ucfirst } split /-/, $field; } =item field_is_official($fname) Returns true if the field is official and known. =cut sub field_is_official($) { my $field = lc shift; return exists $FIELDS{$field}; } =item field_is_allowed_in($fname, @types) Returns true (1) if the field $fname is allowed in all the types listed in the list. Note that you can use type sets instead of individual types (ex: CTRL_FILE_CHANGES | CTRL_CHANGELOG). field_allowed_in(A|B, C) returns true only if the field is allowed in C and either A or B. Undef is returned for non-official fields. =cut sub field_is_allowed_in($@) { my ($field, @types) = @_; $field = lc $field; return unless exists $FIELDS{$field}; return 0 if not scalar(@types); foreach my $type (@types) { next if $type == CTRL_UNKNOWN; # Always allowed return 0 unless $FIELDS{$field}{allowed} & $type; } return 1; } =item field_transfer_single($from, $to, $field) If appropriate, copy the value of the field named $field taken from the $from Dpkg::Control object to the $to Dpkg::Control object. Official fields are copied only if the field is allowed in both types of objects. Custom fields are treated in a specific manner. When the target is not among CTRL_PKG_SRC, CTRL_PKG_DEB or CTRL_FILE_CHANGES, then they are always copied as is (the X- prefix is kept). Otherwise they are not copied except if the target object matches the target destination encoded in the field name. The initial X denoting custom fields can be followed by one or more letters among "S" (Source: corresponds to CTRL_PKG_SRC), "B" (Binary: corresponds to CTRL_PKG_DEB) or "C" (Changes: corresponds to CTRL_FILE_CHANGES). Returns undef if nothing has been copied or the name of the new field added to $to otherwise. =cut sub field_transfer_single($$;$) { my ($from, $to, $field) = @_; $field //= $_; my ($from_type, $to_type) = ($from->get_type(), $to->get_type()); $field = field_capitalize($field); if (field_is_allowed_in($field, $from_type, $to_type)) { $to->{$field} = $from->{$field}; return $field; } elsif ($field =~ /^X([SBC]*)-/i) { my $dest = $1; if (($dest =~ /B/i and $to_type == CTRL_PKG_DEB) or ($dest =~ /S/i and $to_type == CTRL_PKG_SRC) or ($dest =~ /C/i and $to_type == CTRL_FILE_CHANGES)) { my $new = $field; $new =~ s/^X([SBC]*)-//i; $to->{$new} = $from->{$field}; return $new; } elsif ($to_type != CTRL_PKG_DEB and $to_type != CTRL_PKG_SRC and $to_type != CTRL_FILE_CHANGES) { $to->{$field} = $from->{$field}; return $field; } } elsif (not field_is_allowed_in($field, $from_type)) { warning(g_("unknown information field '%s' in input data in %s"), $field, $from->get_option('name') || g_('control information')); } return; } =item field_transfer_all($from, $to) Transfer all appropriate fields from $from to $to. Calls field_transfer_single() on all fields available in $from. Returns the list of fields that have been added to $to. =cut sub field_transfer_all($$) { my ($from, $to) = @_; my (@res, $res); foreach my $k (keys %$from) { $res = field_transfer_single($from, $to, $k); push @res, $res if $res and defined wantarray; } return @res; } =item field_ordered_list($type) Returns an ordered list of fields for a given type of control information. This list can be used to output the fields in a predictable order. The list might be empty for types where the order does not matter much. =cut sub field_ordered_list($) { my $type = shift; if (exists $FIELD_ORDER{$type}) { return map { $FIELDS{$_}{name} } @{$FIELD_ORDER{$type}}; } return (); } =item ($source, $version) = field_parse_binary_source($ctrl) Parse the B<Source> field in a binary package control stanza. The field contains the source package name where it was built from, and optionally a space and the source version enclosed in parenthesis if it is different from the binary version. Returns a list with the $source name, and the source $version, or undef or an empty list when $ctrl does not contain a binary package control stanza. Neither $source nor $version are validated, but that can be done with Dpkg::Package::pkg_name_is_illegal() and Dpkg::Version::version_check(). =cut sub field_parse_binary_source($) { my $ctrl = shift; my $ctrl_type = $ctrl->get_type(); if ($ctrl_type != CTRL_INDEX_PKG and $ctrl_type != CTRL_PKG_DEB and $ctrl_type != CTRL_FILE_CHANGES and $ctrl_type != CTRL_FILE_BUILDINFO and $ctrl_type != CTRL_FILE_STATUS) { return; } my ($source, $version); # For .changes and .buildinfo the Source field always exists, # and there is no Package field. if (exists $ctrl->{'Source'}) { $source = $ctrl->{'Source'}; if ($source =~ m/^([^ ]+) +\(([^)]*)\)$/) { $source = $1; $version = $2; } else { $version = $ctrl->{'Version'}; } } else { $source = $ctrl->{'Package'}; $version = $ctrl->{'Version'}; } return ($source, $version); } =item field_list_src_dep() List of fields that contains dependencies-like information in a source Debian package. =cut sub field_list_src_dep() { my @list = map { $FIELDS{$_}{name} } sort { $FIELDS{$a}{dep_order} <=> $FIELDS{$b}{dep_order} } grep { field_is_allowed_in($_, CTRL_PKG_SRC) and exists $FIELDS{$_}{dependency} } keys %FIELDS; return @list; } =item field_list_pkg_dep() List of fields that contains dependencies-like information in a binary Debian package. The fields that express real dependencies are sorted from the stronger to the weaker. =cut sub field_list_pkg_dep() { my @list = map { $FIELDS{$_}{name} } sort { $FIELDS{$a}{dep_order} <=> $FIELDS{$b}{dep_order} } grep { field_is_allowed_in($_, CTRL_PKG_DEB) and exists $FIELDS{$_}{dependency} } keys %FIELDS; return @list; } =item field_get_dep_type($field) Return the type of the dependency expressed by the given field. Can either be "normal" for a real dependency field (Pre-Depends, Depends, ...) or "union" for other relation fields sharing the same syntax (Conflicts, Breaks, ...). Returns undef for fields which are not dependencies. =cut sub field_get_dep_type($) { my $field = lc shift; return unless exists $FIELDS{$field}; return $FIELDS{$field}{dependency} if exists $FIELDS{$field}{dependency}; return; } =item field_get_sep_type($field) Return the type of the field value separator. Can be one of FIELD_SEP_UNKNOWN, FIELD_SEP_SPACE, FIELD_SEP_COMMA or FIELD_SEP_LINE. =cut sub field_get_sep_type($) { my $field = lc shift; return $FIELDS{$field}{separator} if exists $FIELDS{$field}{separator}; return FIELD_SEP_UNKNOWN; } =item field_register($field, $allowed_types, %opts) Register a new field as being allowed in control information of specified types. %opts is optional =cut sub field_register($$;@) { my ($field, $types, %opts) = @_; $field = lc $field; $FIELDS{$field} = { name => field_capitalize($field), allowed => $types, %opts }; } =item field_insert_after($type, $ref, @fields) Place field after another one ($ref) in output of control information of type $type. =cut sub field_insert_after($$@) { my ($type, $field, @fields) = @_; return 0 if not exists $FIELD_ORDER{$type}; ($field, @fields) = map { lc } ($field, @fields); @{$FIELD_ORDER{$type}} = map { ($_ eq $field) ? ($_, @fields) : $_ } @{$FIELD_ORDER{$type}}; return 1; } =item field_insert_before($type, $ref, @fields) Place field before another one ($ref) in output of control information of type $type. =cut sub field_insert_before($$@) { my ($type, $field, @fields) = @_; return 0 if not exists $FIELD_ORDER{$type}; ($field, @fields) = map { lc } ($field, @fields); @{$FIELD_ORDER{$type}} = map { ($_ eq $field) ? (@fields, $_) : $_ } @{$FIELD_ORDER{$type}}; return 1; } =back =head1 CHANGES =head2 Version 1.01 (dpkg 1.21.0) New function: field_parse_binary_source(). =head2 Version 1.00 (dpkg 1.17.0) Mark the module as public. =cut 1; PK ! ˆ�? ? Control/Fields.pmnu �[��� # Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Control::Fields; use strict; use warnings; our $VERSION = '1.00'; our @EXPORT = @Dpkg::Control::FieldsCore::EXPORT; use Carp; use Exporter qw(import); use Dpkg::Control::FieldsCore; use Dpkg::Vendor qw(run_vendor_hook); # Register vendor specifics fields 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') { my ($field, $allowed_type, @opts) = @{$op}; field_register($field, $allowed_type, @opts); } elsif ($func eq 'insert_before') { my ($type, $ref, @fields) = @{$op}; field_insert_before($type, $ref, @fields); } elsif ($func eq 'insert_after') { my ($type, $ref, @fields) = @{$op}; field_insert_after($type, $ref, @fields); } else { croak "vendor hook register-custom-fields sent bad data: @$op"; } } =encoding utf8 =head1 NAME Dpkg::Control::Fields - manage (list of official) control fields =head1 DESCRIPTION The module contains a list of vendor-neutral and vendor-specific fieldnames with associated meta-data explaining in which type of control information they are allowed. The vendor-neutral fieldnames and all functions are inherited from Dpkg::Control::FieldsCore. =head1 CHANGES =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! |�Q��= �= Control/HashCore.pmnu �[��� # Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2009, 2012-2019, 2021 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::Control::HashCore; use strict; use warnings; our $VERSION = '1.02'; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Control::FieldsCore; # This module cannot use Dpkg::Control::Fields, because that one makes use # of Dpkg::Vendor which at the same time uses this module, which would turn # into a compilation error. We can use Dpkg::Control::FieldsCore instead. use parent qw(Dpkg::Interface::Storable); use overload '%{}' => sub { ${$_[0]}->{fields} }, 'eq' => sub { "$_[0]" eq "$_[1]" }; =encoding utf8 =head1 NAME Dpkg::Control::HashCore - parse and manipulate a block of RFC822-like fields =head1 DESCRIPTION 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). The order in which fields have been set is remembered and is used to be able to dump back the same content. The output order can also be overridden if needed. You can store arbitrary values in the hash, they will always be properly escaped in the output to conform to the syntax of control files. This is relevant mainly for multilines values: while the first line is always output unchanged directly after the field name, supplementary lines are modified. Empty lines and lines containing only dots are prefixed with " ." (space + dot) while other lines are prefixed with a single space. During parsing, trailing spaces are stripped on all lines while leading spaces are stripped only on the first line of each field. =head1 METHODS =over 4 =item $c = Dpkg::Control::Hash->new(%opts) Creates a new object with the indicated options. Supported options are: =over 8 =item allow_pgp Configures the parser to accept OpenPGP signatures around the control information. Value can be 0 (default) or 1. =item allow_duplicate Configures the parser to allow duplicate fields in the control information. The last value overrides any previous values. Value can be 0 (default) or 1. =item keep_duplicate Configure the parser to keep values for duplicate fields found in the control information (when B<allow_duplicate> is enabled), as array references. Value can be 0 (default) or 1. =item drop_empty Defines if empty fields are dropped during the output. Value can be 0 (default) or 1. =item name The user friendly name of the information stored in the object. It might be used in some error messages or warnings. A default name might be set depending on the type. =item is_pgp_signed Set by the parser (starting in dpkg 1.17.0) if it finds an OpenPGP signature around the control information. Value can be 0 (default) or 1, and undef when the option is not supported by the code (in versions older than dpkg 1.17.0). =back =cut sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; # Object is a scalar reference and not a hash ref to avoid # infinite recursion due to overloading hash-dereferencing my $self = \{ in_order => [], out_order => [], is_pgp_signed => 0, allow_pgp => 0, allow_duplicate => 0, keep_duplicate => 0, drop_empty => 0, }; bless $self, $class; $$self->{fields} = Dpkg::Control::HashCore::Tie->new($self); # Options set by the user override default values $$self->{$_} = $opts{$_} foreach keys %opts; return $self; } # There is naturally a circular reference between the tied hash and its # containing object. Happily, the extra layer of scalar reference can # be used to detect the destruction of the object and break the loop so # that everything gets garbage-collected. sub DESTROY { my $self = shift; delete $$self->{fields}; } =item $c->set_options($option, %opts) Changes the value of one or more options. =cut sub set_options { my ($self, %opts) = @_; $$self->{$_} = $opts{$_} foreach keys %opts; } =item $value = $c->get_option($option) Returns the value of the corresponding option. =cut sub get_option { my ($self, $k) = @_; return $$self->{$k}; } =item $c->parse_error($file, $fmt, ...) Prints an error message and dies on syntax parse errors. =cut sub parse_error { my ($self, $file, $msg) = (shift, shift, shift); $msg = sprintf($msg, @_) if (@_); error(g_('syntax error in %s at line %d: %s'), $file, $., $msg); } =item $c->parse($fh, $description) Parse a control file from the given filehandle. Exits in case of errors. $description is used to describe the filehandle, ideally it's a filename or a description of where the data comes from. It's used in error messages. When called multiple times, the parsed fields are accumulated. Returns true if some fields have been parsed. =cut sub parse { my ($self, $fh, $desc) = @_; my $paraborder = 1; my $parabody = 0; my $cf; # Current field my $expect_pgp_sig = 0; local $_; while (<$fh>) { # In the common case there will be just a trailing \n character, # so using chomp here which is very fast will avoid the latter # s/// doing anything, which gives usa significant speed up. chomp; my $armor = $_; s/\s+$//; next if length == 0 and $paraborder; my $lead = substr $_, 0, 1; next if $lead eq '#'; $paraborder = 0; my ($name, $value) = split /\s*:\s*/, $_, 2; if (defined $name and $name =~ m/^\S+?$/) { $parabody = 1; if ($lead eq '-') { $self->parse_error($desc, g_('field cannot start with a hyphen')); } if (exists $self->{$name}) { unless ($$self->{allow_duplicate}) { $self->parse_error($desc, g_('duplicate field %s found'), $name); } if ($$self->{keep_duplicate}) { if (ref $self->{$name} ne 'ARRAY') { # Switch value into an array. $self->{$name} = [ $self->{$name}, $value ]; } else { # Append the value. push @{$self->{$name}}, $value; } } else { # Overwrite with last value. $self->{$name} = $value; } } else { $self->{$name} = $value; } $cf = $name; } elsif (m/^\s(\s*\S.*)$/) { my $line = $1; unless (defined($cf)) { $self->parse_error($desc, g_('continued value line not in field')); } if ($line =~ /^\.+$/) { $line = substr $line, 1; } $self->{$cf} .= "\n$line"; } elsif (length == 0 || ($expect_pgp_sig && $armor =~ m/^-----BEGIN PGP SIGNATURE-----[\r\t ]*$/)) { if ($expect_pgp_sig) { # Skip empty lines $_ = <$fh> while defined && m/^\s*$/; unless (length) { $self->parse_error($desc, g_('expected OpenPGP signature, ' . 'found end of file after blank line')); } chomp; unless (m/^-----BEGIN PGP SIGNATURE-----[\r\t ]*$/) { $self->parse_error($desc, g_('expected OpenPGP signature, ' . "found something else '%s'"), $_); } # Skip OpenPGP signature while (<$fh>) { chomp; last if m/^-----END PGP SIGNATURE-----[\r\t ]*$/; } unless (defined) { $self->parse_error($desc, g_('unfinished OpenPGP signature')); } # This does not mean the signature is correct, that needs to # be verified by gnupg. $$self->{is_pgp_signed} = 1; } last; # Finished parsing one block } elsif ($armor =~ m/^-----BEGIN PGP SIGNED MESSAGE-----[\r\t ]*$/) { $expect_pgp_sig = 1; if ($$self->{allow_pgp} and not $parabody) { # Skip OpenPGP headers while (<$fh>) { last if m/^\s*$/; } } else { $self->parse_error($desc, g_('OpenPGP signature not allowed here')); } } else { $self->parse_error($desc, g_('line with unknown format (not field-colon-value)')); } } if ($expect_pgp_sig and not $$self->{is_pgp_signed}) { $self->parse_error($desc, g_('unfinished OpenPGP signature')); } 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 following regex: /X[SBC]*-$name/i. Return the name of the field found or undef if nothing has been found. =cut sub find_custom_field { my ($self, $name) = @_; foreach my $key (keys %$self) { return $key if $key =~ /^X[SBC]*-\Q$name\E$/i; } return; } =item $c->get_custom_field($name) Identify a user field and retrieve its value. =cut sub get_custom_field { my ($self, $name) = @_; my $key = $self->find_custom_field($name); return $self->{$key} if defined $key; return; } =item $str = $c->output() =item "$c" Get a string representation of the control information. The fields are sorted in the order in which they have been read or set except if the order has been overridden with set_output_order(). =item $c->output($fh) Print the string representation of the control information to a filehandle. =cut sub output { my ($self, $fh) = @_; my $str = ''; my @keys; if (@{$$self->{out_order}}) { my $i = 1; my $imp = {}; $imp->{$_} = $i++ foreach @{$$self->{out_order}}; @keys = sort { if (defined $imp->{$a} && defined $imp->{$b}) { $imp->{$a} <=> $imp->{$b}; } elsif (defined($imp->{$a})) { -1; } elsif (defined($imp->{$b})) { 1; } else { $a cmp $b; } } keys %$self; } else { @keys = @{$$self->{in_order}}; } foreach my $key (@keys) { if (exists $self->{$key}) { my $value = $self->{$key}; # Skip whitespace-only fields next if $$self->{drop_empty} and $value !~ m/\S/; # Escape data to follow control file syntax my ($first_line, @lines) = split /\n/, $value; my $kv = "$key:"; $kv .= ' ' . $first_line if length $first_line; $kv .= "\n"; foreach (@lines) { s/\s+$//; if (length == 0 or /^\.+$/) { $kv .= " .$_\n"; } else { $kv .= " $_\n"; } } # Print it out if ($fh) { print { $fh } $kv or syserr(g_('write error on control data')); } $str .= $kv if defined wantarray; } } 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. =cut sub set_output_order { my ($self, @fields) = @_; $$self->{out_order} = [@fields]; } =item $c->apply_substvars($substvars) Update all fields by replacing the variables references with the corresponding value stored in the Dpkg::Substvars object. =cut sub apply_substvars { my ($self, $substvars, %opts) = @_; # Add substvars to refer to other fields $substvars->set_field_substvars($self, 'F'); foreach my $f (keys %$self) { my $v = $substvars->substvars($self->{$f}, %opts); if ($v ne $self->{$f}) { my $sep; $sep = field_get_sep_type($f); # If we replaced stuff, ensure we're not breaking # a dependency field by introducing empty lines, or multiple # commas if ($sep & (FIELD_SEP_COMMA | FIELD_SEP_LINE)) { # Drop empty/whitespace-only lines $v =~ s/\n[ \t]*(\n|$)/$1/; } if ($sep & FIELD_SEP_COMMA) { $v =~ s/,[\s,]*,/,/g; $v =~ s/^\s*,\s*//; $v =~ s/\s*,\s*$//; } } # Replace ${} with $, which is otherwise an invalid substitution, but # this then makes it possible to use ${} as an escape sequence such # as ${}{VARIABLE}. $v =~ s/\$\{\}/\$/g; $self->{$f} = $v; } } package Dpkg::Control::HashCore::Tie; # 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 # same order. But the order information is stored in a parent object of # type Dpkg::Control. use strict; use warnings; use Dpkg::Control::FieldsCore; use Carp; use Tie::Hash; use parent -norequire, qw(Tie::ExtraHash); # $self->[0] is the real hash # $self->[1] is a reference to the hash contained by the parent object. # This reference bypasses the top-level scalar reference of a # Dpkg::Control::Hash, hence ensuring that reference gets DESTROYed # properly. # Dpkg::Control::Hash->new($parent) # # Return a reference to a tied hash implementing storage of simple # "field: value" mapping as used in many Debian-specific files. sub new { my $class = shift; my $hash = {}; tie %{$hash}, $class, @_; ## no critic (Miscellanea::ProhibitTies) return $hash; } sub TIEHASH { my ($class, $parent) = @_; croak 'parent object must be Dpkg::Control::Hash' if not $parent->isa('Dpkg::Control::HashCore') and not $parent->isa('Dpkg::Control::Hash'); return bless [ {}, $$parent ], $class; } sub FETCH { my ($self, $key) = @_; $key = lc($key); return $self->[0]->{$key} if exists $self->[0]->{$key}; return; } sub STORE { my ($self, $key, $value) = @_; $key = lc($key); if (not exists $self->[0]->{$key}) { push @{$self->[1]->{in_order}}, field_capitalize($key); } $self->[0]->{$key} = $value; } sub EXISTS { my ($self, $key) = @_; $key = lc($key); return exists $self->[0]->{$key}; } sub DELETE { my ($self, $key) = @_; my $parent = $self->[1]; my $in_order = $parent->{in_order}; $key = lc($key); if (exists $self->[0]->{$key}) { delete $self->[0]->{$key}; @{$in_order} = grep { lc ne $key } @{$in_order}; return 1; } else { return 0; } } sub FIRSTKEY { my $self = shift; my $parent = $self->[1]; foreach my $key (@{$parent->{in_order}}) { return $key if exists $self->[0]->{lc $key}; } } sub NEXTKEY { my ($self, $last) = @_; my $parent = $self->[1]; my $found = 0; foreach my $key (@{$parent->{in_order}}) { if ($found) { return $key if exists $self->[0]->{lc $key}; } else { $found = 1 if $key eq $last; } } return; } 1; =back =head1 CHANGES =head2 Version 1.02 (dpkg 1.21.0) New option: "keep_duplicate" in new(). =head2 Version 1.01 (dpkg 1.17.2) New method: $c->parse_error(). =head2 Version 1.00 (dpkg 1.17.0) Mark the module as public. =cut 1; PK ! QŽ`~ ~ Control/Types.pmnu �[��� # 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::Control::Types; use strict; use warnings; our $VERSION = '0.01'; our @EXPORT = qw( CTRL_UNKNOWN CTRL_INFO_SRC CTRL_INFO_PKG CTRL_REPO_RELEASE CTRL_INDEX_SRC CTRL_INDEX_PKG CTRL_PKG_SRC CTRL_PKG_DEB CTRL_FILE_BUILDINFO CTRL_FILE_CHANGES CTRL_FILE_VENDOR CTRL_FILE_STATUS CTRL_CHANGELOG CTRL_COPYRIGHT_HEADER CTRL_COPYRIGHT_FILES CTRL_COPYRIGHT_LICENSE CTRL_TESTS ); use Exporter qw(import); =encoding utf8 =head1 NAME Dpkg::Control::Types - export CTRL_* constants =head1 DESCRIPTION You should not use this module directly. Instead you more likely want to use Dpkg::Control which also re-exports the same constants. This module has been introduced solely to avoid a dependency loop between Dpkg::Control and Dpkg::Control::Fields. =cut use constant { CTRL_UNKNOWN => 0, # First control block in debian/control. CTRL_INFO_SRC => 1, # Subsequent control blocks in debian/control. CTRL_INFO_PKG => 2, # Entry in repository's Sources files. CTRL_INDEX_SRC => 4, # Entry in repository's Packages files. CTRL_INDEX_PKG => 8, # .dsc file of source package. CTRL_PKG_SRC => 16, # DEBIAN/control in binary packages. CTRL_PKG_DEB => 32, # .changes file. CTRL_FILE_CHANGES => 64, # File in $Dpkg::CONFDIR/origins. CTRL_FILE_VENDOR => 128, # $Dpkg::ADMINDIR/status. CTRL_FILE_STATUS => 256, # Output of dpkg-parsechangelog. CTRL_CHANGELOG => 512, # Repository's (In)Release file. CTRL_REPO_RELEASE => 1024, # Header control block in debian/copyright. CTRL_COPYRIGHT_HEADER => 2048, # Files control block in debian/copyright. CTRL_COPYRIGHT_FILES => 4096, # License control block in debian/copyright. CTRL_COPYRIGHT_LICENSE => 8192, # Package test suite control file in debian/tests/control. CTRL_TESTS => 16384, # .buildinfo file CTRL_FILE_BUILDINFO => 32768, }; =head1 CHANGES =head2 Version 0.xx This is a private module. =cut 1; PK ! l0� File.pmnu �[��� # Copyright © 2011 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2012 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::File; use strict; use warnings; our $VERSION = '0.01'; our @EXPORT = qw( file_slurp ); use Exporter qw(import); use Scalar::Util qw(openhandle); use Dpkg::ErrorHandling; use Dpkg::Gettext; sub file_slurp { 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; } 1; PK ! �Ȗ?� � Vars.pmnu �[��� # Copyright © 2007-2009,2012-2013 Guillem Jover <guillem@debian.org> # Copyright © 2007 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Vars; use strict; use warnings; our $VERSION = '0.03'; our @EXPORT = qw( get_source_package set_source_package ); use Exporter qw(import); use Dpkg::ErrorHandling; use Dpkg::Gettext; use Dpkg::Package; my $sourcepackage; sub get_source_package { return $sourcepackage; } sub set_source_package { my $v = shift; my $err = pkg_name_is_illegal($v); error(g_("source package name '%s' is illegal: %s"), $v, $err) if $err; if (not defined($sourcepackage)) { $sourcepackage = $v; } elsif ($v ne $sourcepackage) { error(g_('source package has two conflicting values - %s and %s'), $sourcepackage, $v); } } 1; PK ! 0$~� 3 3 Version.pmnu �[��� # Copyright © Colin Watson <cjwatson@debian.org> # Copyright © Ian Jackson <ijackson@chiark.greenend.org.uk> # Copyright © 2007 Don Armstrong <don@donarmstrong.com>. # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Version; use strict; use warnings; use warnings::register qw(semantic_change::overload::bool); our $VERSION = '1.03'; our @EXPORT = qw( version_compare version_compare_relation version_normalize_relation version_compare_string version_compare_part version_split_digits version_check REL_LT REL_LE REL_EQ REL_GE REL_GT ); use Exporter qw(import); use Carp; use Dpkg::Gettext; use Dpkg::ErrorHandling; use constant { REL_LT => '<<', REL_LE => '<=', REL_EQ => '=', REL_GE => '>=', REL_GT => '>>', }; use overload '<=>' => \&_comparison, 'cmp' => \&_comparison, '""' => sub { return $_[0]->as_string(); }, 'bool' => sub { return $_[0]->is_valid(); }, 'fallback' => 1; =encoding utf8 =head1 NAME Dpkg::Version - handling and comparing dpkg-style version numbers =head1 DESCRIPTION The Dpkg::Version module provides pure-Perl routines to compare dpkg-style version numbers (as used in Debian packages) and also an object oriented interface overriding perl operators to do the right thing when you compare Dpkg::Version object between them. =head1 METHODS =over 4 =item $v = Dpkg::Version->new($version, %opts) Create a new Dpkg::Version object corresponding to the version indicated in the string (scalar) $version. By default it will accepts any string and consider it as a valid version. If you pass the option "check => 1", it will return undef if the version is invalid (see version_check for details). You can always call $v->is_valid() later on to verify that the version is valid. =cut sub new { my ($this, $ver, %opts) = @_; my $class = ref($this) || $this; $ver = "$ver" if ref($ver); # Try to stringify objects if ($opts{check}) { return unless version_check($ver); } my $self = {}; if ($ver =~ /^([^:]*):(.+)$/) { $self->{epoch} = $1; $ver = $2; } else { $self->{epoch} = 0; $self->{no_epoch} = 1; } if ($ver =~ /(.*)-(.*)$/) { $self->{version} = $1; $self->{revision} = $2; } else { $self->{version} = $ver; $self->{revision} = 0; $self->{no_revision} = 1; } return bless $self, $class; } =item boolean evaluation When the Dpkg::Version object is used in a boolean evaluation (for example 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() Returns true if the version is valid, false otherwise. =cut sub is_valid { my $self = shift; return scalar version_check($self); } =item $v->epoch(), $v->version(), $v->revision() Returns the corresponding part of the full version string. =cut sub epoch { my $self = shift; return $self->{epoch}; } sub version { my $self = shift; return $self->{version}; } sub revision { my $self = shift; return $self->{revision}; } =item $v->is_native() Returns true if the version is native, false if it has a revision. =cut sub is_native { my $self = shift; return $self->{no_revision}; } =item $v1 <=> $v2, $v1 < $v2, $v1 <= $v2, $v1 > $v2, $v1 >= $v2 Numerical comparison of various versions numbers. One of the two operands needs to be a Dpkg::Version, the other one can be anything provided that its string representation is a version number. =cut sub _comparison { my ($a, $b, $inverted) = @_; if (not ref($b) or not $b->isa('Dpkg::Version')) { $b = Dpkg::Version->new($b); } ($a, $b) = ($b, $a) if $inverted; my $r = version_compare_part($a->epoch(), $b->epoch()); return $r if $r; $r = version_compare_part($a->version(), $b->version()); return $r if $r; return version_compare_part($a->revision(), $b->revision()); } =item "$v", $v->as_string(), $v->as_string(%options) Accepts an optional option hash reference, affecting the string conversion. Options: =over 8 =item omit_epoch (defaults to 0) Omit the epoch, if present, in the output string. =item omit_revision (defaults to 0) Omit the revision, if present, in the output string. =back Returns the string representation of the version number. =cut sub as_string { my ($self, %opts) = @_; my $no_epoch = $opts{omit_epoch} || $self->{no_epoch}; my $no_revision = $opts{omit_revision} || $self->{no_revision}; my $str = ''; $str .= $self->{epoch} . ':' unless $no_epoch; $str .= $self->{version}; $str .= '-' . $self->{revision} unless $no_revision; return $str; } =back =head1 FUNCTIONS All the functions are exported by default. =over 4 =item version_compare($a, $b) Returns -1 if $a is earlier than $b, 0 if they are equal and 1 if $a is later than $b. If $a or $b are not valid version numbers, it dies with an error. =cut sub version_compare($$) { my ($a, $b) = @_; my $va = Dpkg::Version->new($a, check => 1); defined($va) || error(g_('%s is not a valid version'), "$a"); my $vb = Dpkg::Version->new($b, check => 1); defined($vb) || error(g_('%s is not a valid version'), "$b"); return $va <=> $vb; } =item version_compare_relation($a, $rel, $b) Returns the result (0 or 1) of the given comparison operation. This function is implemented on top of version_compare(). Allowed values for $rel are the exported constants REL_GT, REL_GE, REL_EQ, REL_LE, REL_LT. Use version_normalize_relation() if you have an input string containing the operator. =cut sub version_compare_relation($$$) { my ($a, $op, $b) = @_; my $res = version_compare($a, $b); if ($op eq REL_GT) { return $res > 0; } elsif ($op eq REL_GE) { return $res >= 0; } elsif ($op eq REL_EQ) { return $res == 0; } elsif ($op eq REL_LE) { return $res <= 0; } elsif ($op eq REL_LT) { return $res < 0; } else { croak "unsupported relation for version_compare_relation(): '$op'"; } } =item $rel = version_normalize_relation($rel_string) Returns the normalized constant of the relation $rel (a value among REL_GT, REL_GE, REL_EQ, REL_LE and REL_LT). Supported relations names in input are: "gt", "ge", "eq", "le", "lt", ">>", ">=", "=", "<=", "<<". ">" and "<" are also supported but should not be used as they are obsolete aliases of ">=" and "<=". =cut sub version_normalize_relation($) { my $op = shift; warning('relation %s is deprecated: use %s or %s', $op, "$op$op", "$op=") if ($op eq '>' or $op eq '<'); if ($op eq '>>' or $op eq 'gt') { return REL_GT; } elsif ($op eq '>=' or $op eq 'ge' or $op eq '>') { return REL_GE; } elsif ($op eq '=' or $op eq 'eq') { return REL_EQ; } elsif ($op eq '<=' or $op eq 'le' or $op eq '<') { return REL_LE; } elsif ($op eq '<<' or $op eq 'lt') { return REL_LT; } else { croak "bad relation '$op'"; } } =item version_compare_string($a, $b) String comparison function used for comparing non-numerical parts of version numbers. Returns -1 if $a is earlier than $b, 0 if they are equal and 1 if $a is later than $b. The "~" character always sort lower than anything else. Digits sort lower than non-digits. Among remaining characters alphabetic characters (A-Z, a-z) sort lower than the other ones. Within each range, the ASCII decimal value of the character is used to sort between characters. =cut sub _version_order { my $x = shift; if ($x eq '~') { return -1; } elsif ($x =~ /^\d$/) { return $x * 1 + 1; } elsif ($x =~ /^[A-Za-z]$/) { return ord($x); } else { return ord($x) + 256; } } sub version_compare_string($$) { my @a = map { _version_order($_) } split(//, shift); my @b = map { _version_order($_) } split(//, shift); while (1) { my ($a, $b) = (shift @a, shift @b); return 0 if not defined($a) and not defined($b); $a ||= 0; # Default order for "no character" $b ||= 0; return 1 if $a > $b; return -1 if $a < $b; } } =item version_compare_part($a, $b) Compare two corresponding sub-parts of a version number (either upstream version or debian revision). Each parameter is split by version_split_digits() and resulting items are compared together. As soon as a difference happens, it returns -1 if $a is earlier than $b, 0 if they are equal and 1 if $a is later than $b. =cut sub version_compare_part($$) { my @a = version_split_digits(shift); my @b = version_split_digits(shift); while (1) { my ($a, $b) = (shift @a, shift @b); return 0 if not defined($a) and not defined($b); $a ||= 0; # Default value for lack of version $b ||= 0; if ($a =~ /^\d+$/ and $b =~ /^\d+$/) { # Numerical comparison my $cmp = $a <=> $b; return $cmp if $cmp; } else { # String comparison my $cmp = version_compare_string($a, $b); return $cmp if $cmp; } } } =item @items = version_split_digits($version) Splits a string in items that are each entirely composed either of digits or of non-digits. For instance for "1.024~beta1+svn234" it would return ("1", ".", "024", "~beta", "1", "+svn", "234"). =cut sub version_split_digits($) { my $version = shift; return split /(?<=\d)(?=\D)|(?<=\D)(?=\d)/, $version; } =item ($ok, $msg) = version_check($version) =item $ok = version_check($version) Checks the validity of $version as a version number. Returns 1 in $ok if the version is valid, 0 otherwise. In the latter case, $msg contains a description of the problem with the $version scalar. =cut sub version_check($) { my $version = shift; my $str; if (defined $version) { $str = "$version"; $version = Dpkg::Version->new($str) unless ref($version); } if (not defined($str) or not length($str)) { my $msg = g_('version number cannot be empty'); return (0, $msg) if wantarray; return 0; } if (not defined $version->epoch() or not length $version->epoch()) { my $msg = sprintf(g_('epoch part of the version number cannot be empty')); return (0, $msg) if wantarray; return 0; } if (not defined $version->version() or not length $version->version()) { my $msg = g_('upstream version cannot be empty'); return (0, $msg) if wantarray; return 0; } if (not defined $version->revision() or not length $version->revision()) { my $msg = sprintf(g_('revision cannot be empty')); return (0, $msg) if wantarray; return 0; } if ($version->version() =~ m/^[^\d]/) { my $msg = g_('version number does not start with digit'); return (0, $msg) if wantarray; return 0; } if ($str =~ m/([^-+:.0-9a-zA-Z~])/o) { my $msg = sprintf g_("version number contains illegal character '%s'"), $1; return (0, $msg) if wantarray; return 0; } if ($version->epoch() !~ /^\d*$/) { my $msg = sprintf(g_('epoch part of the version number ' . "is not a number: '%s'"), $version->epoch()); return (0, $msg) if wantarray; return 0; } return (1, '') if wantarray; return 1; } =back =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(). New method: $v->is_native(). =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! �=Aԯ. �. BuildFlags.pmnu �[��� # Copyright © 2010-2011 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::BuildFlags; use strict; use warnings; our $VERSION = '1.04'; use Dpkg (); use Dpkg::Gettext; use Dpkg::Build::Env; use Dpkg::ErrorHandling; use Dpkg::Vendor qw(run_vendor_hook); =encoding utf8 =head1 NAME Dpkg::BuildFlags - query build flags =head1 DESCRIPTION This class is used by dpkg-buildflags and can be used to query the same information. =head1 METHODS =over 4 =item $bf = Dpkg::BuildFlags->new() Create a new Dpkg::BuildFlags object. It will be initialized based on the value of several configuration files and environment variables. =cut sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; my $self = { }; bless $self, $class; $self->load_vendor_defaults(); return $self; } =item $bf->load_vendor_defaults() Reset the flags stored to the default set provided by the vendor. =cut sub load_vendor_defaults { my $self = shift; $self->{features} = {}; $self->{flags} = { ASFLAGS => '', CPPFLAGS => '', CFLAGS => '', CXXFLAGS => '', OBJCFLAGS => '', OBJCXXFLAGS => '', GCJFLAGS => '', DFLAGS => '', FFLAGS => '', FCFLAGS => '', LDFLAGS => '', }; $self->{origin} = { ASFLAGS => 'vendor', CPPFLAGS => 'vendor', CFLAGS => 'vendor', CXXFLAGS => 'vendor', OBJCFLAGS => 'vendor', OBJCXXFLAGS => 'vendor', GCJFLAGS => 'vendor', DFLAGS => 'vendor', FFLAGS => 'vendor', FCFLAGS => 'vendor', LDFLAGS => 'vendor', }; $self->{maintainer} = { ASFLAGS => 0, CPPFLAGS => 0, CFLAGS => 0, CXXFLAGS => 0, OBJCFLAGS => 0, OBJCXXFLAGS => 0, GCJFLAGS => 0, DFLAGS => 0, FFLAGS => 0, FCFLAGS => 0, LDFLAGS => 0, }; # The vendor hook will add the feature areas build flags. run_vendor_hook('update-buildflags', $self); } =item $bf->load_system_config() Update flags from the system configuration. =cut sub load_system_config { my $self = shift; $self->update_from_conffile("$Dpkg::CONFDIR/buildflags.conf", 'system'); } =item $bf->load_user_config() Update flags from the user configuration. =cut sub load_user_config { my $self = shift; my $confdir = $ENV{XDG_CONFIG_HOME}; $confdir ||= $ENV{HOME} . '/.config' if length $ENV{HOME}; if (length $confdir) { $self->update_from_conffile("$confdir/dpkg/buildflags.conf", 'user'); } } =item $bf->load_environment_config() Update flags based on user directives stored in the environment. See dpkg-buildflags(1) for details. =cut sub load_environment_config { my $self = shift; foreach my $flag (keys %{$self->{flags}}) { my $envvar = 'DEB_' . $flag . '_SET'; if (Dpkg::Build::Env::has($envvar)) { $self->set($flag, Dpkg::Build::Env::get($envvar), 'env'); } $envvar = 'DEB_' . $flag . '_STRIP'; if (Dpkg::Build::Env::has($envvar)) { $self->strip($flag, Dpkg::Build::Env::get($envvar), 'env'); } $envvar = 'DEB_' . $flag . '_APPEND'; if (Dpkg::Build::Env::has($envvar)) { $self->append($flag, Dpkg::Build::Env::get($envvar), 'env'); } $envvar = 'DEB_' . $flag . '_PREPEND'; if (Dpkg::Build::Env::has($envvar)) { $self->prepend($flag, Dpkg::Build::Env::get($envvar), 'env'); } } } =item $bf->load_maintainer_config() Update flags based on maintainer directives stored in the environment. See dpkg-buildflags(1) for details. =cut sub load_maintainer_config { my $self = shift; foreach my $flag (keys %{$self->{flags}}) { my $envvar = 'DEB_' . $flag . '_MAINT_SET'; if (Dpkg::Build::Env::has($envvar)) { $self->set($flag, Dpkg::Build::Env::get($envvar), undef, 1); } $envvar = 'DEB_' . $flag . '_MAINT_STRIP'; if (Dpkg::Build::Env::has($envvar)) { $self->strip($flag, Dpkg::Build::Env::get($envvar), undef, 1); } $envvar = 'DEB_' . $flag . '_MAINT_APPEND'; if (Dpkg::Build::Env::has($envvar)) { $self->append($flag, Dpkg::Build::Env::get($envvar), undef, 1); } $envvar = 'DEB_' . $flag . '_MAINT_PREPEND'; if (Dpkg::Build::Env::has($envvar)) { $self->prepend($flag, Dpkg::Build::Env::get($envvar), undef, 1); } } } =item $bf->load_config() Call successively load_system_config(), load_user_config(), load_environment_config() and load_maintainer_config() to update the default build flags defined by the vendor. =cut sub load_config { my $self = shift; $self->load_system_config(); $self->load_user_config(); $self->load_environment_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 $source (if defined). Record it as maintainer modified if $maint is defined and true. =cut sub set { my ($self, $flag, $value, $src, $maint) = @_; $self->{flags}->{$flag} = $value; $self->{origin}->{$flag} = $src if defined $src; $self->{maintainer}->{$flag} = $maint if $maint; } =item $bf->set_feature($area, $feature, $enabled) Update the boolean state of whether a specific feature within a known feature area has been enabled. The only currently known feature areas are "future", "qa", "sanitize", "hardening" and "reproducible". =cut sub set_feature { my ($self, $area, $feature, $enabled) = @_; $self->{features}{$area}{$feature} = $enabled; } =item $bf->strip($flag, $value, $source, $maint) Update the build flag $flag by stripping the flags listed in $value and record its origin as $source (if defined). Record it as maintainer modified if $maint is defined and true. =cut sub strip { my ($self, $flag, $value, $src, $maint) = @_; foreach my $tostrip (split(/\s+/, $value)) { next unless length $tostrip; $self->{flags}->{$flag} =~ s/(^|\s+)\Q$tostrip\E(\s+|$)/ /g; } $self->{flags}->{$flag} =~ s/^\s+//g; $self->{flags}->{$flag} =~ s/\s+$//g; $self->{origin}->{$flag} = $src if defined $src; $self->{maintainer}->{$flag} = $maint if $maint; } =item $bf->append($flag, $value, $source, $maint) Append the options listed in $value to the current value of the flag $flag. Record its origin as $source (if defined). Record it as maintainer modified if $maint is defined and true. =cut sub append { my ($self, $flag, $value, $src, $maint) = @_; if (length($self->{flags}->{$flag})) { $self->{flags}->{$flag} .= " $value"; } else { $self->{flags}->{$flag} = $value; } $self->{origin}->{$flag} = $src if defined $src; $self->{maintainer}->{$flag} = $maint if $maint; } =item $bf->prepend($flag, $value, $source, $maint) Prepend the options listed in $value to the current value of the flag $flag. Record its origin as $source (if defined). Record it as maintainer modified if $maint is defined and true. =cut sub prepend { my ($self, $flag, $value, $src, $maint) = @_; if (length($self->{flags}->{$flag})) { $self->{flags}->{$flag} = "$value " . $self->{flags}->{$flag}; } else { $self->{flags}->{$flag} = $value; } $self->{origin}->{$flag} = $src if defined $src; $self->{maintainer}->{$flag} = $maint if $maint; } =item $bf->update_from_conffile($file, $source) Update the current build flags based on the configuration directives contained in $file. See dpkg-buildflags(1) for the format of the directives. $source is the origin recorded for any build flag set or modified. =cut sub update_from_conffile { my ($self, $file, $src) = @_; local $_; return unless -e $file; open(my $conf_fh, '<', $file) or syserr(g_('cannot read %s'), $file); while (<$conf_fh>) { chomp; next if /^\s*#/; # Skip comments next if /^\s*$/; # Skip empty lines if (/^(append|prepend|set|strip)\s+(\S+)\s+(\S.*\S)\s*$/i) { my ($op, $flag, $value) = ($1, $2, $3); unless (exists $self->{flags}->{$flag}) { warning(g_('line %d of %s mentions unknown flag %s'), $., $file, $flag); $self->{flags}->{$flag} = ''; } if (lc($op) eq 'set') { $self->set($flag, $value, $src); } elsif (lc($op) eq 'strip') { $self->strip($flag, $value, $src); } elsif (lc($op) eq 'append') { $self->append($flag, $value, $src); } elsif (lc($op) eq 'prepend') { $self->prepend($flag, $value, $src); } } else { warning(g_('line %d of %s is invalid, it has been ignored'), $., $file); } } close($conf_fh); } =item $bf->get($flag) Return the value associated to the flag. It might be undef if the flag doesn't exist. =cut sub get { my ($self, $key) = @_; return $self->{flags}{$key}; } =item $bf->get_feature_areas() Return the feature areas (i.e. the area values has_features will return true for). =cut sub get_feature_areas { my $self = shift; return keys %{$self->{features}}; } =item $bf->get_features($area) Return, for the given area, a hash with keys as feature names, and values as booleans indicating whether the feature is enabled or not. =cut sub get_features { my ($self, $area) = @_; return %{$self->{features}{$area}}; } =item $bf->get_origin($flag) Return the origin associated to the flag. It might be undef if the flag doesn't exist. =cut sub get_origin { my ($self, $key) = @_; return $self->{origin}{$key}; } =item $bf->is_maintainer_modified($flag) Return true if the flag is modified by the maintainer. =cut sub is_maintainer_modified { my ($self, $key) = @_; return $self->{maintainer}{$key}; } =item $bf->has_features($area) Returns true if the given area of features is known, and false otherwise. The only currently recognized feature areas are "future", "qa", "sanitize", "hardening" and "reproducible". =cut sub has_features { my ($self, $area) = @_; return exists $self->{features}{$area}; } =item $bf->has($option) Returns a boolean indicating whether the flags exists in the object. =cut sub has { my ($self, $key) = @_; return exists $self->{flags}{$key}; } =item @flags = $bf->list() Returns the list of flags stored in the object. =cut sub list { my $self = shift; my @list = sort keys %{$self->{flags}}; return @list; } =back =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 $bf->get_features. New method $bf->is_maintainer_modified() and new optional parameter to $bf->set(), $bf->append(), $bf->prepend(), $bf->strip(). =head2 Version 1.02 (dpkg 1.16.2) New methods: $bf->get_features(), $bf->has_features(), $bf->set_feature(). =head2 Version 1.01 (dpkg 1.16.1) New method: $bf->prepend() very similar to append(). Implement support of the prepend operation everywhere. New method: $bf->load_maintainer_config() that update the build flags based on the package maintainer directives. =head2 Version 1.00 (dpkg 1.15.7) Mark the module as public. =cut 1; PK ! 3���+ �+ Checksums.pmnu �[��� # Copyright © 2008 Frank Lichtenheld <djpig@debian.org> # Copyright © 2008, 2012-2015 Guillem Jover <guillem@debian.org> # Copyright © 2010 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Checksums; use strict; use warnings; our $VERSION = '1.04'; our @EXPORT = qw( checksums_is_supported checksums_get_list checksums_get_property ); use Exporter qw(import); use Digest; use Dpkg::Gettext; use Dpkg::ErrorHandling; =encoding utf8 =head1 NAME Dpkg::Checksums - generate and manipulate file checksums =head1 DESCRIPTION This module provides a class that can generate and manipulate various file checksums as well as some methods to query information about supported checksums. =head1 FUNCTIONS =over 4 =cut my $CHECKSUMS = { md5 => { name => 'MD5', regex => qr/[0-9a-f]{32}/, strong => 0, }, sha1 => { name => 'SHA-1', regex => qr/[0-9a-f]{40}/, strong => 0, }, sha256 => { name => 'SHA-256', regex => qr/[0-9a-f]{64}/, strong => 1, }, }; =item @list = checksums_get_list() Returns the list of supported checksums algorithms. =cut sub checksums_get_list() { my @list = sort keys %{$CHECKSUMS}; return @list; } =item $bool = checksums_is_supported($alg) Returns a boolean indicating whether the given checksum algorithm is supported. The checksum algorithm is case-insensitive. =cut sub checksums_is_supported($) { my $alg = shift; return exists $CHECKSUMS->{lc($alg)}; } =item $value = checksums_get_property($alg, $property) Returns the requested property of the checksum algorithm. Returns undef if either the property or the checksum algorithm doesn't exist. Valid properties currently include "name" (returns the name of the digest algorithm), "regex" for the regular expression describing the common string representation of the checksum, and "strong" for a boolean describing whether the checksum algorithm is considered cryptographically strong. =cut sub checksums_get_property($$) { my ($alg, $property) = @_; return unless checksums_is_supported($alg); return $CHECKSUMS->{lc($alg)}{$property}; } =back =head1 METHODS =over 4 =item $ck = Dpkg::Checksums->new() Create a new Dpkg::Checksums object. This object is able to store the checksums of several files to later export them or verify them. =cut sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; my $self = {}; bless $self, $class; $self->reset(); return $self; } =item $ck->reset() Forget about all checksums stored. The object is again in the same state as if it was newly created. =cut sub reset { my $self = shift; $self->{files} = []; $self->{checksums} = {}; $self->{size} = {}; } =item $ck->add_from_file($filename, %opts) Add or verify checksums information for the file $filename. The file must exists for the call to succeed. If you don't want the given filename to appear when you later export the checksums you might want to set the "key" option with the public name that you want to use. Also if you don't want to generate all the checksums, you can pass an array reference of the wanted checksums in the "checksums" option. It the object already contains checksums information associated the filename (or key), it will error out if the newly computed information does not match what's stored, and the caller did not request that it be updated with the boolean "update" option. =cut sub add_from_file { my ($self, $file, %opts) = @_; my $key = exists $opts{key} ? $opts{key} : $file; my @alg; if (exists $opts{checksums}) { push @alg, map { lc } @{$opts{checksums}}; } else { push @alg, checksums_get_list(); } push @{$self->{files}}, $key unless exists $self->{size}{$key}; (my @s = stat($file)) or syserr(g_('cannot fstat file %s'), $file); if (not $opts{update} and exists $self->{size}{$key} and $self->{size}{$key} != $s[7]) { error(g_('file %s has size %u instead of expected %u'), $file, $s[7], $self->{size}{$key}); } $self->{size}{$key} = $s[7]; foreach my $alg (@alg) { my $digest = Digest->new($CHECKSUMS->{$alg}{name}); open my $fh, '<', $file or syserr(g_('cannot open file %s'), $file); $digest->addfile($fh); close $fh; my $newsum = $digest->hexdigest; if (not $opts{update} and exists $self->{checksums}{$key}{$alg} and $self->{checksums}{$key}{$alg} ne $newsum) { error(g_('file %s has checksum %s instead of expected %s (algorithm %s)'), $file, $newsum, $self->{checksums}{$key}{$alg}, $alg); } $self->{checksums}{$key}{$alg} = $newsum; } } =item $ck->add_from_string($alg, $value, %opts) Add checksums of type $alg that are stored in the $value variable. $value can be multi-lines, each line should be a space separated list of checksum, file size and filename. Leading or trailing spaces are not allowed. It the object already contains checksums information associated to the filenames, it will error out if the newly read information does not match what's stored, and the caller did not request that it be updated with the boolean "update" option. =cut sub add_from_string { my ($self, $alg, $fieldtext, %opts) = @_; $alg = lc($alg); my $rx_fname = qr/[0-9a-zA-Z][-+:.,=0-9a-zA-Z_~]+/; my $regex = checksums_get_property($alg, 'regex'); my $checksums = $self->{checksums}; for my $checksum (split /\n */, $fieldtext) { next if $checksum eq ''; unless ($checksum =~ m/^($regex)\s+(\d+)\s+($rx_fname)$/) { error(g_('invalid line in %s checksums string: %s'), $alg, $checksum); } my ($sum, $size, $file) = ($1, $2, $3); if (not $opts{update} and exists($checksums->{$file}{$alg}) and $checksums->{$file}{$alg} ne $sum) { error(g_("conflicting checksums '%s' and '%s' for file '%s'"), $checksums->{$file}{$alg}, $sum, $file); } if (not $opts{update} and exists $self->{size}{$file} and $self->{size}{$file} != $size) { error(g_("conflicting file sizes '%u' and '%u' for file '%s'"), $self->{size}{$file}, $size, $file); } push @{$self->{files}}, $file unless exists $self->{size}{$file}; $checksums->{$file}{$alg} = $sum; $self->{size}{$file} = $size; } } =item $ck->add_from_control($control, %opts) Read checksums from Checksums-* fields stored in the Dpkg::Control object $control. It uses $self->add_from_string() on the field values to do the actual work. If the option "use_files_for_md5" evaluates to true, then the "Files" field is used in place of the "Checksums-Md5" field. By default the option is false. =cut sub add_from_control { my ($self, $control, %opts) = @_; $opts{use_files_for_md5} //= 0; foreach my $alg (checksums_get_list()) { my $key = "Checksums-$alg"; $key = 'Files' if ($opts{use_files_for_md5} and $alg eq 'md5'); if (exists $control->{$key}) { $self->add_from_string($alg, $control->{$key}, %opts); } } } =item @files = $ck->get_files() Return the list of files whose checksums are stored in the object. =cut sub get_files { my $self = shift; return @{$self->{files}}; } =item $bool = $ck->has_file($file) Return true if we have checksums for the given file. Returns false otherwise. =cut sub has_file { my ($self, $file) = @_; return exists $self->{size}{$file}; } =item $ck->remove_file($file) Remove all checksums of the given file. =cut sub remove_file { my ($self, $file) = @_; return unless $self->has_file($file); delete $self->{checksums}{$file}; delete $self->{size}{$file}; @{$self->{files}} = grep { $_ ne $file } $self->get_files(); } =item $checksum = $ck->get_checksum($file, $alg) Return the checksum of type $alg for the requested $file. This will not compute the checksum but only return the checksum stored in the object, if any. If $alg is not defined, it returns a reference to a hash: keys are the checksum algorithms and values are the checksums themselves. The hash returned must not be modified, it's internal to the object. =cut sub get_checksum { my ($self, $file, $alg) = @_; $alg = lc($alg) if defined $alg; if (exists $self->{checksums}{$file}) { return $self->{checksums}{$file} unless defined $alg; return $self->{checksums}{$file}{$alg}; } return; } =item $size = $ck->get_size($file) Return the size of the requested file if it's available in the object. =cut sub get_size { my ($self, $file) = @_; return $self->{size}{$file}; } =item $bool = $ck->has_strong_checksums($file) Return a boolean on whether the file has a strong checksum. =cut sub has_strong_checksums { my ($self, $file) = @_; foreach my $alg (checksums_get_list()) { return 1 if defined $self->get_checksum($file, $alg) and checksums_get_property($alg, 'strong'); } return 0; } =item $ck->export_to_string($alg, %opts) Return a multi-line string containing the checksums of type $alg. The string can be stored as-is in a Checksum-* field of a Dpkg::Control object. =cut sub export_to_string { my ($self, $alg, %opts) = @_; my $res = ''; foreach my $file ($self->get_files()) { my $sum = $self->get_checksum($file, $alg); my $size = $self->get_size($file); next unless defined $sum and defined $size; $res .= "\n$sum $size $file"; } return $res; } =item $ck->export_to_control($control, %opts) Export the checksums in the Checksums-* fields of the Dpkg::Control $control object. =cut sub export_to_control { my ($self, $control, %opts) = @_; $opts{use_files_for_md5} //= 0; foreach my $alg (checksums_get_list()) { my $key = "Checksums-$alg"; $key = 'Files' if ($opts{use_files_for_md5} and $alg eq 'md5'); $control->{$key} = $self->export_to_string($alg, %opts); } } =back =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. New member: $ck->has_strong_checksums(). =head2 Version 1.02 (dpkg 1.18.0) Obsolete property: Getting the 'program' checksum property will warn and return undef, the Digest module is used internally now. New property: Add new 'name' property with the name of the Digest algorithm to use. =head2 Version 1.01 (dpkg 1.17.6) New argument: Accept an options argument in $ck->export_to_string(). New option: Accept new option 'update' in $ck->add_from_file() and $ck->add_from_control(). =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! �'1� � BuildOptions.pmnu �[��� # Copyright © 2007 Frank Lichtenheld <djpig@debian.org> # Copyright © 2008, 2012-2017 Guillem Jover <guillem@debian.org> # Copyright © 2010 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::BuildOptions; use strict; use warnings; our $VERSION = '1.02'; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Build::Env; =encoding utf8 =head1 NAME Dpkg::BuildOptions - parse and update build options =head1 DESCRIPTION This class can be used to manipulate options stored in environment variables like DEB_BUILD_OPTIONS and DEB_BUILD_MAINT_OPTIONS. =head1 METHODS =over 4 =item $bo = Dpkg::BuildOptions->new(%opts) Create a new Dpkg::BuildOptions object. It will be initialized based on the value of the environment variable named $opts{envvar} (or DEB_BUILD_OPTIONS if that option is not set). =cut sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; my $self = { options => {}, source => {}, envvar => $opts{envvar} // 'DEB_BUILD_OPTIONS', }; bless $self, $class; $self->merge(Dpkg::Build::Env::get($self->{envvar}), $self->{envvar}); return $self; } =item $bo->reset() Reset the object to not have any option (it's empty). =cut sub reset { my $self = shift; $self->{options} = {}; $self->{source} = {}; } =item $bo->merge($content, $source) Merge the options set in $content and record that they come from the source $source. $source is mainly used in warning messages currently to indicate where invalid options have been detected. $content is a space separated list of options with optional assigned values like "nocheck parallel=2". =cut sub merge { my ($self, $content, $source) = @_; return 0 unless defined $content; my $count = 0; foreach (split(/\s+/, $content)) { unless (/^([a-z][a-z0-9_-]*)(?:=(\S*))?$/) { warning(g_('invalid flag in %s: %s'), $source, $_); next; } $count += $self->set($1, $2, $source); } return $count; } =item $bo->set($option, $value, [$source]) Store the given option in the object with the given value. It's legitimate for a value to be undefined if the option is a simple boolean (its presence means true, its absence means false). The $source is optional and indicates where the option comes from. The known options have their values checked for sanity. Options without values have their value removed and options with invalid values are discarded. =cut sub set { my ($self, $key, $value, $source) = @_; # Sanity checks if ($key =~ /^(terse|noopt|nostrip|nocheck)$/ && defined($value)) { $value = undef; } elsif ($key eq 'parallel') { $value //= ''; return 0 if $value !~ /^\d*$/; } $self->{options}{$key} = $value; $self->{source}{$key} = $source; return 1; } =item $bo->get($option) Return the value associated to the option. It might be undef even if the option exists. You might want to check with $bo->has($option) to verify if the option is stored in the object. =cut sub get { my ($self, $key) = @_; return $self->{options}{$key}; } =item $bo->has($option) Returns a boolean indicating whether the option is stored in the object. =cut sub has { my ($self, $key) = @_; return exists $self->{options}{$key}; } =item $bo->parse_features($option, $use_feature) Parse the $option values, as a set of known features to enable or disable, as specified in the $use_feature hash reference. 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 or malformed features will emit warnings. =cut sub parse_features { my ($self, $option, $use_feature) = @_; foreach my $feature (split(/,/, $self->get($option) // '')) { $feature = lc $feature; if ($feature =~ s/^([+-])//) { my $value = ($1 eq '+') ? 1 : 0; if ($feature eq 'all') { $use_feature->{$_} = $value foreach keys %{$use_feature}; } else { if (exists $use_feature->{$feature}) { $use_feature->{$feature} = $value; } else { warning(g_('unknown %s feature in %s variable: %s'), $option, $self->{envvar}, $feature); } } } else { warning(g_('incorrect value in %s option of %s variable: %s'), $option, $self->{envvar}, $feature); } } } =item $string = $bo->output($fh) Return a string representation of the build options suitable to be assigned to an environment variable. Can optionally output that string to the given filehandle. =cut sub output { my ($self, $fh) = @_; my $o = $self->{options}; my $res = join(' ', map { defined($o->{$_}) ? $_ . '=' . $o->{$_} : $_ } sort keys %$o); print { $fh } $res if defined $fh; return $res; } =item $bo->export([$var]) Export the build options to the given environment variable. If omitted, the environment variable defined at creation time is assumed. The value set to the variable is also returned. =cut sub export { my ($self, $var) = @_; $var //= $self->{envvar}; my $content = $self->output(); Dpkg::Build::Env::set($var, $content); return $content; } =back =head1 CHANGES =head2 Version 1.02 (dpkg 1.18.19) New method: $bo->parse_features(). =head2 Version 1.01 (dpkg 1.16.1) Enable to use another environment variable instead of DEB_BUILD_OPTIONS. Thus add support for the "envvar" option at creation time. =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! a�!B� � Getopt.pmnu �[��� # Copyright © 2014 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::Getopt; use strict; use warnings; our $VERSION = '0.02'; our @EXPORT = qw( normalize_options ); use Exporter qw(import); sub normalize_options { my (%opts) = @_; my $norm = 1; my @args; @args = map { if ($norm and m/^(-[A-Za-z])(.+)$/) { ($1, $2) } elsif ($norm and m/^(--[A-Za-z-]+)=(.*)$/) { ($1, $2) } else { $norm = 0 if defined $opts{delim} and $_ eq $opts{delim}; $_; } } @{$opts{args}}; return @args; } 1; PK ! ��:~. ~. IPC.pmnu �[��� # Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2008 Frank Lichtenheld <djpig@debian.org> # Copyright © 2008-2010, 2012-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::IPC; use strict; use warnings; our $VERSION = '1.02'; our @EXPORT = qw( spawn wait_child ); use Carp; use Exporter qw(import); use Dpkg::ErrorHandling; use Dpkg::Gettext; =encoding utf8 =head1 NAME Dpkg::IPC - helper functions for IPC =head1 DESCRIPTION Dpkg::IPC offers helper functions to allow you to execute other programs in an easy, yet flexible way, while hiding all the gory details of IPC (Inter-Process Communication) from you. =head1 FUNCTIONS =over 4 =item $pid = spawn(%opts) Creates a child process and executes another program in it. The arguments are interpreted as a hash of options, specifying how to handle the in and output of the program to execute. Returns the pid of the child process (unless the wait_child option was given). Any error will cause the function to exit with one of the Dpkg::ErrorHandling functions. Options: =over 4 =item exec Can be either a scalar, i.e. the name of the program to be executed, or an array reference, i.e. the name of the program plus additional arguments. Note that the program will never be executed via the shell, so you can't specify additional arguments in the scalar string and you can't use any shell facilities like globbing. Mandatory Option. =item from_file, to_file, error_to_file Filename as scalar. Standard input/output/error of the child process will be redirected to the file specified. =item from_handle, to_handle, error_to_handle Filehandle. Standard input/output/error of the child process will be dup'ed from the handle. =item from_pipe, to_pipe, error_to_pipe Scalar reference or object based on IO::Handle. A pipe will be opened for each of the two options and either the reading (C<to_pipe> and C<error_to_pipe>) or the writing end (C<from_pipe>) will be returned in the referenced scalar. Standard input/output/error of the child process will be dup'ed to the other ends of the pipes. =item from_string, to_string, error_to_string Scalar reference. Standard input/output/error of the child process will be redirected to the string given as reference. Note that it wouldn't be strictly necessary to use a scalar reference for C<from_string>, as the string is not modified in any way. This was chosen only for reasons of symmetry with C<to_string> and C<error_to_string>. C<to_string> and C<error_to_string> imply the C<wait_child> option. =item wait_child Scalar. If containing a true value, wait_child() will be called before returning. The return value of spawn() will be a true value, not the pid. =item nocheck Scalar. Option of the wait_child() call. =item timeout Scalar. Option of the wait_child() call. =item chdir Scalar. The child process will chdir in the indicated directory before calling exec. =item env Hash reference. The child process will populate %ENV with the items of the hash before calling exec. This allows exporting environment variables. =item delete_env Array reference. The child process will remove all environment variables listed in the array before calling exec. =item sig Hash reference. The child process will populate %SIG with the items of the hash before calling exec. This allows setting signal dispositions. =item delete_sig Array reference. The child process will reset all signals listed in the array to their default dispositions before calling exec. =back =cut sub _sanity_check_opts { my (%opts) = @_; croak 'exec parameter is mandatory in spawn()' unless $opts{exec}; my $to = my $error_to = my $from = 0; foreach my $thing (qw(file handle string pipe)) { $to++ if $opts{"to_$thing"}; $error_to++ if $opts{"error_to_$thing"}; $from++ if $opts{"from_$thing"}; } croak 'not more than one of to_* parameters is allowed' if $to > 1; croak 'not more than one of error_to_* parameters is allowed' if $error_to > 1; croak 'not more than one of from_* parameters is allowed' if $from > 1; foreach my $param (qw(to_string error_to_string from_string)) { if (exists $opts{$param} and (not ref $opts{$param} or ref $opts{$param} ne 'SCALAR')) { croak "parameter $param must be a scalar reference"; } } foreach my $param (qw(to_pipe error_to_pipe from_pipe)) { if (exists $opts{$param} and (not ref $opts{$param} or (ref $opts{$param} ne 'SCALAR' and not $opts{$param}->isa('IO::Handle')))) { croak "parameter $param must be a scalar reference or " . 'an IO::Handle object'; } } if (exists $opts{timeout} and defined($opts{timeout}) and $opts{timeout} !~ /^\d+$/) { croak 'parameter timeout must be an integer'; } if (exists $opts{env} and ref($opts{env}) ne 'HASH') { croak 'parameter env must be a hash reference'; } if (exists $opts{delete_env} and ref($opts{delete_env}) ne 'ARRAY') { croak 'parameter delete_env must be an array reference'; } if (exists $opts{sig} and ref($opts{sig}) ne 'HASH') { croak 'parameter sig must be a hash reference'; } if (exists $opts{delete_sig} and ref($opts{delete_sig}) ne 'ARRAY') { croak 'parameter delete_sig must be an array reference'; } return %opts; } sub spawn { my (%opts) = @_; my @prog; _sanity_check_opts(%opts); $opts{close_in_child} //= []; if (ref($opts{exec}) =~ /ARRAY/) { push @prog, @{$opts{exec}}; } elsif (not ref($opts{exec})) { push @prog, $opts{exec}; } else { croak 'invalid exec parameter in spawn()'; } my ($from_string_pipe, $to_string_pipe, $error_to_string_pipe); if ($opts{to_string}) { $opts{to_pipe} = \$to_string_pipe; $opts{wait_child} = 1; } if ($opts{error_to_string}) { $opts{error_to_pipe} = \$error_to_string_pipe; $opts{wait_child} = 1; } if ($opts{from_string}) { $opts{from_pipe} = \$from_string_pipe; } # Create pipes if needed my ($input_pipe, $output_pipe, $error_pipe); if ($opts{from_pipe}) { pipe($opts{from_handle}, $input_pipe) or syserr(g_('pipe for %s'), "@prog"); ${$opts{from_pipe}} = $input_pipe; push @{$opts{close_in_child}}, $input_pipe; } if ($opts{to_pipe}) { pipe($output_pipe, $opts{to_handle}) or syserr(g_('pipe for %s'), "@prog"); ${$opts{to_pipe}} = $output_pipe; push @{$opts{close_in_child}}, $output_pipe; } if ($opts{error_to_pipe}) { pipe($error_pipe, $opts{error_to_handle}) or syserr(g_('pipe for %s'), "@prog"); ${$opts{error_to_pipe}} = $error_pipe; push @{$opts{close_in_child}}, $error_pipe; } # Fork and exec my $pid = fork(); syserr(g_('cannot fork for %s'), "@prog") unless defined $pid; if (not $pid) { # Define environment variables if ($opts{env}) { foreach (keys %{$opts{env}}) { $ENV{$_} = $opts{env}{$_}; } } if ($opts{delete_env}) { delete $ENV{$_} foreach (@{$opts{delete_env}}); } # Define signal dispositions. if ($opts{sig}) { foreach (keys %{$opts{sig}}) { $SIG{$_} = $opts{sig}{$_}; } } if ($opts{delete_sig}) { delete $SIG{$_} foreach (@{$opts{delete_sig}}); } # Change the current directory if ($opts{chdir}) { chdir($opts{chdir}) or syserr(g_('chdir to %s'), $opts{chdir}); } # Redirect STDIN if needed if ($opts{from_file}) { open(STDIN, '<', $opts{from_file}) or syserr(g_('cannot open %s'), $opts{from_file}); } elsif ($opts{from_handle}) { open(STDIN, '<&', $opts{from_handle}) or syserr(g_('reopen stdin')); # has been duped, can be closed push @{$opts{close_in_child}}, $opts{from_handle}; } # Redirect STDOUT if needed if ($opts{to_file}) { open(STDOUT, '>', $opts{to_file}) or syserr(g_('cannot write %s'), $opts{to_file}); } elsif ($opts{to_handle}) { open(STDOUT, '>&', $opts{to_handle}) or syserr(g_('reopen stdout')); # has been duped, can be closed push @{$opts{close_in_child}}, $opts{to_handle}; } # Redirect STDERR if needed if ($opts{error_to_file}) { open(STDERR, '>', $opts{error_to_file}) or syserr(g_('cannot write %s'), $opts{error_to_file}); } elsif ($opts{error_to_handle}) { open(STDERR, '>&', $opts{error_to_handle}) or syserr(g_('reopen stdout')); # has been duped, can be closed push @{$opts{close_in_child}}, $opts{error_to_handle}; } # Close some inherited filehandles close($_) foreach (@{$opts{close_in_child}}); # Execute the program exec({ $prog[0] } @prog) or syserr(g_('unable to execute %s'), "@prog"); } # Close handle that we can't use any more close($opts{from_handle}) if exists $opts{from_handle}; close($opts{to_handle}) if exists $opts{to_handle}; close($opts{error_to_handle}) if exists $opts{error_to_handle}; if ($opts{from_string}) { print { $from_string_pipe } ${$opts{from_string}}; close($from_string_pipe); } if ($opts{to_string}) { local $/ = undef; ${$opts{to_string}} = readline($to_string_pipe); } if ($opts{error_to_string}) { local $/ = undef; ${$opts{error_to_string}} = readline($error_to_string_pipe); } if ($opts{wait_child}) { my $cmdline = "@prog"; if ($opts{env}) { foreach (keys %{$opts{env}}) { $cmdline = "$_=\"" . $opts{env}{$_} . "\" $cmdline"; } } wait_child($pid, nocheck => $opts{nocheck}, timeout => $opts{timeout}, cmdline => $cmdline); return 1; } return $pid; } =item wait_child($pid, %opts) Takes as first argument the pid of the process to wait for. Remaining arguments are taken as a hash of options. Returns nothing. Fails if the child has been ended by a signal or if it exited non-zero. Options: =over 4 =item cmdline String to identify the child process in error messages. Defaults to "child process". =item nocheck If true do not check the return status of the child (and thus do not fail it has been killed or if it exited with a non-zero return code). =item timeout Set a maximum time to wait for the process, after that kill the process and fail with an error message. =back =cut sub wait_child { my ($pid, %opts) = @_; $opts{cmdline} //= g_('child process'); croak 'no PID set, cannot wait end of process' unless $pid; eval { local $SIG{ALRM} = sub { die "alarm\n" }; alarm($opts{timeout}) if defined($opts{timeout}); $pid == waitpid($pid, 0) or syserr(g_('wait for %s'), $opts{cmdline}); alarm(0) if defined($opts{timeout}); }; if ($@) { die $@ unless $@ eq "alarm\n"; kill 'TERM', $pid; error(P_("%s didn't complete in %d second", "%s didn't complete in %d seconds", $opts{timeout}), $opts{cmdline}, $opts{timeout}); } unless ($opts{nocheck}) { subprocerr($opts{cmdline}) if $?; } } 1; __END__ =back =head1 CHANGES =head2 Version 1.02 (dpkg 1.18.0) Change options: wait_child() now kills the process when reaching the 'timeout'. =head2 Version 1.01 (dpkg 1.17.11) New options: spawn() now accepts 'sig' and 'delete_sig'. =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =head1 SEE ALSO Dpkg, Dpkg::ErrorHandling PK ! �," " Conf.pmnu �[��� # Copyright © 2009-2010 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Conf; use strict; use warnings; our $VERSION = '1.04'; use Carp; use Dpkg::Gettext; use Dpkg::ErrorHandling; use parent qw(Dpkg::Interface::Storable); use overload '@{}' => sub { return [ $_[0]->get_options() ] }, fallback => 1; =encoding utf8 =head1 NAME Dpkg::Conf - parse dpkg configuration files =head1 DESCRIPTION The Dpkg::Conf object can be used to read options from a configuration file. It can export an array that can then be parsed exactly like @ARGV. =head1 METHODS =over 4 =item $conf = Dpkg::Conf->new(%opts) Create a new Dpkg::Conf object. Some options can be set through %opts: if allow_short evaluates to true (it defaults to false), then short options are allowed in the configuration file, they should be prepended with a single hyphen. =cut sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; my $self = { options => [], allow_short => 0, }; foreach my $opt (keys %opts) { $self->{$opt} = $opts{$opt}; } bless $self, $class; return $self; } =item @$conf =item @options = $conf->get_options() Returns the list of options that can be parsed like @ARGV. =cut sub get_options { my $self = shift; return @{$self->{options}}; } =item $conf->load($file) Read options from a file. Return the number of options parsed. =item $conf->load_system_config($file) Read options from a system configuration file. Return the number of options parsed. =cut sub load_system_config { my ($self, $file) = @_; return 0 unless -e "$Dpkg::CONFDIR/$file"; return $self->load("$Dpkg::CONFDIR/$file"); } =item $conf->load_user_config($file) Read options from a user configuration file. It will try to use the XDG directory, either $XDG_CONFIG_HOME/dpkg/ or $HOME/.config/dpkg/. Return the number of options parsed. =cut sub load_user_config { my ($self, $file) = @_; my $confdir = $ENV{XDG_CONFIG_HOME}; $confdir ||= $ENV{HOME} . '/.config' if length $ENV{HOME}; return 0 unless length $confdir; return 0 unless -e "$confdir/dpkg/$file"; return $self->load("$confdir/dpkg/$file") if length $confdir; return 0; } =item $conf->load_config($file) Read options from system and user configuration files. Return the number of options parsed. =cut sub load_config { my ($self, $file) = @_; my $nopts = 0; $nopts += $self->load_system_config($file); $nopts += $self->load_user_config($file); return $nopts; } =item $conf->parse($fh) Parse options from a file handle. When called multiple times, the parsed options are accumulated. Return the number of options parsed. =cut sub parse { my ($self, $fh, $desc) = @_; my $count = 0; local $_; while (<$fh>) { chomp; s/^\s+//; # Strip leading spaces s/\s+$//; # Strip trailing spaces s/\s+=\s+/=/; # Remove spaces around the first = s/\s+/=/ unless m/=/; # First spaces becomes = if no = # Skip empty lines and comments next if /^#/ or length == 0; if (/^-[^-]/ and not $self->{allow_short}) { warning(g_('short option not allowed in %s, line %d'), $desc, $.); next; } if (/^([^=]+)(?:=(.*))?$/) { my ($name, $value) = ($1, $2); $name = "--$name" unless $name =~ /^-/; if (defined $value) { $value =~ s/^"(.*)"$/$1/ or $value =~ s/^'(.*)'$/$1/; push @{$self->{options}}, "$name=$value"; } else { push @{$self->{options}}, $name; } $count++; } else { warning(g_('invalid syntax for option in %s, line %d'), $desc, $.); } } return $count; } =item $conf->filter(%opts) Filter the list of options, either removing or keeping all those that return true when $opts{remove}->($option) or $opts{keep}->($option) is called. =cut sub filter { my ($self, %opts) = @_; my $remove = $opts{remove} // sub { 0 }; my $keep = $opts{keep} // sub { 1 }; @{$self->{options}} = grep { not $remove->($_) and $keep->($_) } @{$self->{options}}; } =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. =item "$conf" Return a string representation of the content. =cut sub output { my ($self, $fh) = @_; my $ret = ''; foreach my $opt ($self->get_options()) { $opt =~ s/^--//; $opt =~ s/^([^=]+)=(.*)$/$1 = "$2"/; $opt .= "\n"; print { $fh } $opt if defined $fh; $ret .= $opt; } 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(). Obsolete methods: $conf->get(), $conf->set(). New methods: $conf->load_system_config(), $conf->load_system_user(), $conf->load_config(). =head2 Version 1.02 (dpkg 1.18.5) New option: Accept new option 'format_argv' in $conf->filter(). New methods: $conf->get(), $conf->set(). =head2 Version 1.01 (dpkg 1.15.8) New method: $conf->filter() =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! p�7>Y Y Source/Patch.pmnu �[��� # Copyright © 2008 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2008-2010, 2012-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::Patch; use strict; use warnings; our $VERSION = '0.01'; use POSIX qw(:errno_h :sys_wait_h); use File::Find; use File::Basename; use File::Spec; use File::Path qw(make_path); use File::Compare; use Fcntl ':mode'; use Time::HiRes qw(stat); use Dpkg; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::IPC; use Dpkg::Source::Functions qw(fs_time); use parent qw(Dpkg::Compression::FileHandle); sub create { my ($self, %opts) = @_; $self->ensure_open('w'); # Creates the file *$self->{errors} = 0; *$self->{empty} = 1; if ($opts{old} and $opts{new} and $opts{filename}) { $opts{old} = '/dev/null' unless -e $opts{old}; $opts{new} = '/dev/null' unless -e $opts{new}; if (-d $opts{old} and -d $opts{new}) { $self->add_diff_directory($opts{old}, $opts{new}, %opts); } elsif (-f $opts{old} and -f $opts{new}) { $self->add_diff_file($opts{old}, $opts{new}, %opts); } else { $self->_fail_not_same_type($opts{old}, $opts{new}, $opts{filename}); } $self->finish() unless $opts{nofinish}; } } sub set_header { my ($self, $header) = @_; *$self->{header} = $header; } sub add_diff_file { my ($self, $old, $new, %opts) = @_; $opts{include_timestamp} //= 0; my $handle_binary = $opts{handle_binary_func} // sub { my ($self, $old, $new, %opts) = @_; my $file = $opts{filename}; $self->_fail_with_msg($file, g_('binary file contents changed')); }; # Optimization to avoid forking diff if unnecessary return 1 if compare($old, $new, 4096) == 0; # Default diff options my @options; if ($opts{options}) { push @options, @{$opts{options}}; } else { push @options, '-p'; } # Add labels if ($opts{label_old} and $opts{label_new}) { if ($opts{include_timestamp}) { my $ts = (stat($old))[9]; my $t = POSIX::strftime('%Y-%m-%d %H:%M:%S', gmtime($ts)); $opts{label_old} .= sprintf("\t%s.%09d +0000", $t, ($ts - int($ts)) * 1_000_000_000); $ts = (stat($new))[9]; $t = POSIX::strftime('%Y-%m-%d %H:%M:%S', gmtime($ts)); $opts{label_new} .= sprintf("\t%s.%09d +0000", $t, ($ts - int($ts)) * 1_000_000_000); } else { # Space in filenames need special treatment $opts{label_old} .= "\t" if $opts{label_old} =~ / /; $opts{label_new} .= "\t" if $opts{label_new} =~ / /; } push @options, '-L', $opts{label_old}, '-L', $opts{label_new}; } # Generate diff my $diffgen; my $diff_pid = spawn( exec => [ 'diff', '-u', @options, '--', $old, $new ], env => { LC_ALL => 'C', LANG => 'C', TZ => 'UTC0' }, to_pipe => \$diffgen, ); # Check diff and write it in patch file my $difflinefound = 0; my $binary = 0; local $_; while (<$diffgen>) { if (m/^(?:binary|[^-+\@ ].*\bdiffer\b)/i) { $binary = 1; $handle_binary->($self, $old, $new, %opts); last; } elsif (m/^[-+\@ ]/) { $difflinefound++; } elsif (m/^\\ /) { warning(g_('file %s has no final newline (either ' . 'original or modified version)'), $new); } else { chomp; error(g_("unknown line from diff -u on %s: '%s'"), $new, $_); } if (*$self->{empty} and defined(*$self->{header})) { $self->print(*$self->{header}) or syserr(g_('failed to write')); *$self->{empty} = 0; } print { $self } $_ or syserr(g_('failed to write')); } close($diffgen) or syserr('close on diff pipe'); wait_child($diff_pid, nocheck => 1, cmdline => "diff -u @options -- $old $new"); # Verify diff process ended successfully # Exit code of diff: 0 => no difference, 1 => diff ok, 2 => error # Ignore error if binary content detected my $exit = WEXITSTATUS($?); unless (WIFEXITED($?) && ($exit == 0 || $exit == 1 || $binary)) { subprocerr(g_('diff on %s'), $new); } return ($exit == 0 || $exit == 1); } sub add_diff_directory { my ($self, $old, $new, %opts) = @_; # TODO: make this function more configurable # - offer to disable some checks my $basedir = $opts{basedirname} || basename($new); my $diff_ignore; if ($opts{diff_ignore_func}) { $diff_ignore = $opts{diff_ignore_func}; } elsif ($opts{diff_ignore_regex}) { $diff_ignore = sub { return $_[0] =~ /$opts{diff_ignore_regex}/o }; } else { $diff_ignore = sub { return 0 }; } my @diff_files; my %files_in_new; my $scan_new = sub { my $fn = (length > length($new)) ? substr($_, length($new) + 1) : '.'; return if $diff_ignore->($fn); $files_in_new{$fn} = 1; lstat("$new/$fn") or syserr(g_('cannot stat file %s'), "$new/$fn"); my $mode = S_IMODE((lstat(_))[2]); my $size = (lstat(_))[7]; if (-l _) { unless (-l "$old/$fn") { $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); return; } my $n = readlink("$new/$fn"); unless (defined $n) { syserr(g_('cannot read link %s'), "$new/$fn"); } my $n2 = readlink("$old/$fn"); unless (defined $n2) { syserr(g_('cannot read link %s'), "$old/$fn"); } unless ($n eq $n2) { $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); } } elsif (-f _) { my $old_file = "$old/$fn"; if (not lstat("$old/$fn")) { if ($! != ENOENT) { syserr(g_('cannot stat file %s'), "$old/$fn"); } $old_file = '/dev/null'; } elsif (not -f _) { $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); return; } my $label_old = "$basedir.orig/$fn"; if ($opts{use_dev_null}) { $label_old = $old_file if $old_file eq '/dev/null'; } push @diff_files, [$fn, $mode, $size, $old_file, "$new/$fn", $label_old, "$basedir/$fn"]; } elsif (-p _) { unless (-p "$old/$fn") { $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); } } elsif (-b _ || -c _ || -S _) { $self->_fail_with_msg("$new/$fn", g_('device or socket is not allowed')); } elsif (-d _) { if (not lstat("$old/$fn")) { if ($! != ENOENT) { syserr(g_('cannot stat file %s'), "$old/$fn"); } } elsif (not -d _) { $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); } } else { $self->_fail_with_msg("$new/$fn", g_('unknown file type')); } }; my $scan_old = sub { my $fn = (length > length($old)) ? substr($_, length($old) + 1) : '.'; return if $diff_ignore->($fn); return if $files_in_new{$fn}; lstat("$old/$fn") or syserr(g_('cannot stat file %s'), "$old/$fn"); if (-f _) { 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']; } } elsif (-d _) { warning(g_('ignoring deletion of directory %s'), $fn); } elsif (-l _) { warning(g_('ignoring deletion of symlink %s'), $fn); } else { $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); } }; find({ wanted => $scan_new, no_chdir => 1 }, $new); find({ wanted => $scan_old, no_chdir => 1 }, $old); if ($opts{order_from} and -e $opts{order_from}) { my $order_from = Dpkg::Source::Patch->new( filename => $opts{order_from}); my $analysis = $order_from->analyze($basedir, verbose => 0); my %patchorder; my $i = 0; foreach my $fn (@{$analysis->{patchorder}}) { $fn =~ s{^[^/]+/}{}; $patchorder{$fn} = $i++; } # 'quilt refresh' sorts files as follows: # - Any files in the existing patch come first, in the order in # which they appear in the existing patch. # - New files follow, sorted lexicographically. # This seems a reasonable policy to follow, and avoids autopatches # being shuffled when they are regenerated. foreach my $diff_file (sort { $a->[0] cmp $b->[0] } @diff_files) { my $fn = $diff_file->[0]; $patchorder{$fn} //= $i++; } @diff_files = sort { $patchorder{$a->[0]} <=> $patchorder{$b->[0]} } @diff_files; } else { @diff_files = sort { $a->[0] cmp $b->[0] } @diff_files; } foreach my $diff_file (@diff_files) { my ($fn, $mode, $size, $old_file, $new_file, $label_old, $label_new) = @$diff_file; my $success = $self->add_diff_file($old_file, $new_file, filename => $fn, label_old => $label_old, label_new => $label_new, %opts); if ($success and $old_file eq '/dev/null' and $new_file ne '/dev/null') { if (not $size) { warning(g_("newly created empty file '%s' will not " . 'be represented in diff'), $fn); } else { if ($mode & (S_IXUSR | S_IXGRP | S_IXOTH)) { warning(g_("executable mode %04o of '%s' will " . 'not be represented in diff'), $mode, $fn) unless $fn eq 'debian/rules'; } if ($mode & (S_ISUID | S_ISGID | S_ISVTX)) { warning(g_("special mode %04o of '%s' will not " . 'be represented in diff'), $mode, $fn); } } } } } sub finish { my $self = shift; close($self) or syserr(g_('cannot close %s'), $self->get_filename()); return not *$self->{errors}; } sub register_error { my $self = shift; *$self->{errors}++; } sub _fail_with_msg { my ($self, $file, $msg) = @_; errormsg(g_('cannot represent change to %s: %s'), $file, $msg); $self->register_error(); } sub _fail_not_same_type { my ($self, $old, $new, $file) = @_; my $old_type = get_type($old); my $new_type = get_type($new); errormsg(g_('cannot represent change to %s:'), $file); errormsg(g_(' new version is %s'), $new_type); errormsg(g_(' old version is %s'), $old_type); $self->register_error(); } sub _getline { my $handle = shift; my $line = <$handle>; if (defined $line) { # Strip end-of-line chars chomp($line); $line =~ s/\r$//; } return $line; } # Fetch the header filename ignoring the optional timestamp sub _fetch_filename { my ($diff, $header) = @_; # Strip any leading spaces. $header =~ s/^\s+//; # Is it a C-style string? if ($header =~ m/^"/) { error(g_('diff %s patches file with C-style encoded filename'), $diff); } else { # Tab is the official separator, it's always used when # filename contain spaces. Try it first, otherwise strip on space # if there's no tab $header =~ s/\s.*// unless $header =~ s/\t.*//; } return $header; } sub _intuit_file_patched { my ($old, $new) = @_; return $new unless defined $old; return $old unless defined $new; return $new if -e $new and not -e $old; return $old if -e $old and not -e $new; # We don't consider the case where both files are non-existent and # where patch picks the one with the fewest directories to create # since dpkg-source will pre-create the required directories # Precalculate metrics used by patch my ($tmp_o, $tmp_n) = ($old, $new); my ($len_o, $len_n) = (length($old), length($new)); $tmp_o =~ s{[/\\]+}{/}g; $tmp_n =~ s{[/\\]+}{/}g; my $nb_comp_o = ($tmp_o =~ tr{/}{/}); my $nb_comp_n = ($tmp_n =~ tr{/}{/}); $tmp_o =~ s{^.*/}{}; $tmp_n =~ s{^.*/}{}; my ($blen_o, $blen_n) = (length($tmp_o), length($tmp_n)); # Decide like patch would if ($nb_comp_o != $nb_comp_n) { return ($nb_comp_o < $nb_comp_n) ? $old : $new; } elsif ($blen_o != $blen_n) { return ($blen_o < $blen_n) ? $old : $new; } elsif ($len_o != $len_n) { return ($len_o < $len_n) ? $old : $new; } return $old; } # check diff for sanity, find directories to create as a side effect sub analyze { my ($self, $destdir, %opts) = @_; $opts{verbose} //= 1; my $diff = $self->get_filename(); my %filepatched; my %dirtocreate; my @patchorder; my $patch_header = ''; my $diff_count = 0; my $line = _getline($self); HUNK: while (defined $line or not eof $self) { my (%path, %fn); # Skip comments leading up to the patch (if any). Although we do not # look for an Index: pseudo-header in the comments, because we would # not use it anyway, as we require both ---/+++ filename headers. while (1) { if ($line =~ /^(?:--- |\+\+\+ |@@ -)/) { last; } else { $patch_header .= "$line\n"; } $line = _getline($self); last HUNK if not defined $line; } $diff_count++; # read file header (---/+++ pair) unless ($line =~ s/^--- //) { error(g_("expected ^--- in line %d of diff '%s'"), $., $diff); } $path{old} = $line = _fetch_filename($diff, $line); if ($line ne '/dev/null' and $line =~ s{^[^/]*/+}{$destdir/}) { $fn{old} = $line; } if ($line =~ /\.dpkg-orig$/) { error(g_("diff '%s' patches file with name ending in .dpkg-orig"), $diff); } $line = _getline($self); unless (defined $line) { error(g_("diff '%s' finishes in middle of ---/+++ (line %d)"), $diff, $.); } unless ($line =~ s/^\+\+\+ //) { error(g_("line after --- isn't as expected in diff '%s' (line %d)"), $diff, $.); } $path{new} = $line = _fetch_filename($diff, $line); if ($line ne '/dev/null' and $line =~ s{^[^/]*/+}{$destdir/}) { $fn{new} = $line; } unless (defined $fn{old} or defined $fn{new}) { error(g_("none of the filenames in ---/+++ are valid in diff '%s' (line %d)"), $diff, $.); } # Safety checks on both filenames that patch could use foreach my $key ('old', 'new') { next unless defined $fn{$key}; if ($path{$key} =~ m{/\.\./}) { error(g_('%s contains an insecure path: %s'), $diff, $path{$key}); } my $path = $fn{$key}; while (1) { if (-l $path) { error(g_('diff %s modifies file %s through a symlink: %s'), $diff, $fn{$key}, $path); } last unless $path =~ s{/+[^/]*$}{}; last if length($path) <= length($destdir); # $destdir is assumed safe } } if ($path{old} eq '/dev/null' and $path{new} eq '/dev/null') { error(g_("original and modified files are /dev/null in diff '%s' (line %d)"), $diff, $.); } elsif ($path{new} eq '/dev/null') { error(g_("file removal without proper filename in diff '%s' (line %d)"), $diff, $. - 1) unless defined $fn{old}; if ($opts{verbose}) { warning(g_('diff %s removes a non-existing file %s (line %d)'), $diff, $fn{old}, $.) unless -e $fn{old}; } } my $fn = _intuit_file_patched($fn{old}, $fn{new}); my $dirname = $fn; if ($dirname =~ s{/[^/]+$}{} and not -d $dirname) { $dirtocreate{$dirname} = 1; } if (-e $fn and not -f _) { error(g_("diff '%s' patches something which is not a plain file"), $diff); } if ($filepatched{$fn}) { $filepatched{$fn}++; if ($opts{fatal_dupes}) { error(g_("diff '%s' patches files multiple times; split the " . 'diff in multiple files or merge the hunks into a ' . 'single one'), $diff); } elsif ($opts{verbose} and $filepatched{$fn} == 2) { warning(g_("diff '%s' patches file %s more than once"), $diff, $fn) } } else { $filepatched{$fn} = 1; push @patchorder, $fn; } # read hunks my $hunk = 0; while (defined($line = _getline($self))) { # read hunk header (@@) next if $line =~ /^\\ /; last unless $line =~ /^@@ -\d+(,(\d+))? \+\d+(,(\d+))? @\@(?: .*)?$/; my ($olines, $nlines) = ($1 ? $2 : 1, $3 ? $4 : 1); # read hunk while ($olines || $nlines) { unless (defined($line = _getline($self))) { if (($olines == $nlines) and ($olines < 3)) { warning(g_("unexpected end of diff '%s'"), $diff) if $opts{verbose}; last; } else { error(g_("unexpected end of diff '%s'"), $diff); } } next if $line =~ /^\\ /; # Check stats if ($line =~ /^ / or length $line == 0) { --$olines; --$nlines; } elsif ($line =~ /^-/) { --$olines; } elsif ($line =~ /^\+/) { --$nlines; } else { error(g_("expected [ +-] at start of line %d of diff '%s'"), $., $diff); } } $hunk++; } unless ($hunk) { error(g_("expected ^\@\@ at line %d of diff '%s'"), $., $diff); } } close($self); unless ($diff_count) { warning(g_("diff '%s' doesn't contain any patch"), $diff) if $opts{verbose}; } *$self->{analysis}{$destdir}{dirtocreate} = \%dirtocreate; *$self->{analysis}{$destdir}{filepatched} = \%filepatched; *$self->{analysis}{$destdir}{patchorder} = \@patchorder; *$self->{analysis}{$destdir}{patchheader} = $patch_header; return *$self->{analysis}{$destdir}; } sub prepare_apply { my ($self, $analysis, %opts) = @_; if ($opts{create_dirs}) { foreach my $dir (keys %{$analysis->{dirtocreate}}) { eval { make_path($dir, { mode => 0777 }) }; syserr(g_('cannot create directory %s'), $dir) if $@; } } } sub apply { my ($self, $destdir, %opts) = @_; # Set default values to options $opts{force_timestamp} //= 1; $opts{remove_backup} //= 1; $opts{create_dirs} //= 1; $opts{options} ||= [ '-t', '-F', '0', '-N', '-p1', '-u', '-V', 'never', '-b', '-z', '.dpkg-orig']; $opts{add_options} //= []; push @{$opts{options}}, @{$opts{add_options}}; # Check the diff and create missing directories my $analysis = $self->analyze($destdir, %opts); $self->prepare_apply($analysis, %opts); # Apply the patch $self->ensure_open('r'); my ($stdout, $stderr) = ('', ''); spawn( exec => [ $Dpkg::PROGPATCH, @{$opts{options}} ], chdir => $destdir, env => { LC_ALL => 'C', LANG => 'C', PATCH_GET => '0' }, delete_env => [ 'POSIXLY_CORRECT' ], # ensure expected patch behaviour wait_child => 1, nocheck => 1, from_handle => $self->get_filehandle(), to_string => \$stdout, error_to_string => \$stderr, ); if ($?) { print { *STDOUT } $stdout; print { *STDERR } $stderr; subprocerr("LC_ALL=C $Dpkg::PROGPATCH " . join(' ', @{$opts{options}}) . ' < ' . $self->get_filename()); } $self->close(); # Reset the timestamp of all the patched files # and remove .dpkg-orig files my @files = keys %{$analysis->{filepatched}}; my $now = $opts{timestamp}; $now //= fs_time($files[0]) if $opts{force_timestamp} && scalar @files; foreach my $fn (@files) { if ($opts{force_timestamp}) { utime($now, $now, $fn) or $! == ENOENT or syserr(g_('cannot change timestamp for %s'), $fn); } if ($opts{remove_backup}) { $fn .= '.dpkg-orig'; unlink($fn) or syserr(g_('remove patch backup file %s'), $fn); } } return $analysis; } # Verify if check will work... sub check_apply { my ($self, $destdir, %opts) = @_; # Set default values to options $opts{create_dirs} //= 1; $opts{options} ||= [ '--dry-run', '-s', '-t', '-F', '0', '-N', '-p1', '-u', '-V', 'never', '-b', '-z', '.dpkg-orig']; $opts{add_options} //= []; push @{$opts{options}}, @{$opts{add_options}}; # Check the diff and create missing directories my $analysis = $self->analyze($destdir, %opts); $self->prepare_apply($analysis, %opts); # Apply the patch $self->ensure_open('r'); my $patch_pid = spawn( exec => [ $Dpkg::PROGPATCH, @{$opts{options}} ], chdir => $destdir, env => { LC_ALL => 'C', LANG => 'C', PATCH_GET => '0' }, delete_env => [ 'POSIXLY_CORRECT' ], # ensure expected patch behaviour from_handle => $self->get_filehandle(), to_file => '/dev/null', error_to_file => '/dev/null', ); wait_child($patch_pid, nocheck => 1); my $exit = WEXITSTATUS($?); subprocerr("$Dpkg::PROGPATCH --dry-run") unless WIFEXITED($?); $self->close(); return ($exit == 0); } # Helper functions sub get_type { my $file = shift; if (not lstat($file)) { return g_('nonexistent') if $! == ENOENT; syserr(g_('cannot stat %s'), $file); } else { -f _ && return g_('plain file'); -d _ && return g_('directory'); -l _ && return sprintf(g_('symlink to %s'), readlink($file)); -b _ && return g_('block device'); -c _ && return g_('character device'); -p _ && return g_('named pipe'); -S _ && return g_('named socket'); } } 1; PK ! J v�� � Source/BinaryFiles.pmnu �[��� # 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; PK ! ���� � Source/Format.pmnu �[��� # 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; PK ! e{)�J- J- Source/Quilt.pmnu �[��� # Copyright © 2008-2012 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Source::Quilt; use strict; use warnings; our $VERSION = '0.02'; use List::Util qw(any none); use File::Spec; use File::Copy; use File::Find; use File::Path qw(make_path); use File::Basename; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Source::Patch; use Dpkg::Source::Functions qw(erasedir chmod_if_needed fs_time); use Dpkg::Vendor qw(get_current_vendor); sub new { my ($this, $dir, %opts) = @_; my $class = ref($this) || $this; my $self = { dir => $dir, }; bless $self, $class; $self->load_series(); $self->load_db(); return $self; } sub setup_db { my $self = shift; my $db_dir = $self->get_db_file(); if (not -d $db_dir) { mkdir $db_dir or syserr(g_('cannot mkdir %s'), $db_dir); } my $file = $self->get_db_file('.version'); if (not -e $file) { open(my $version_fh, '>', $file) or syserr(g_('cannot write %s'), $file); print { $version_fh } "2\n"; close($version_fh); } # The files below are used by quilt to know where patches are stored # and what file contains the patch list (supported by quilt >= 0.48-5 # in Debian). $file = $self->get_db_file('.quilt_patches'); if (not -e $file) { open(my $qpatch_fh, '>', $file) or syserr(g_('cannot write %s'), $file); print { $qpatch_fh } "debian/patches\n"; close($qpatch_fh); } $file = $self->get_db_file('.quilt_series'); if (not -e $file) { open(my $qseries_fh, '>', $file) or syserr(g_('cannot write %s'), $file); my $series = $self->get_series_file(); $series = (File::Spec->splitpath($series))[2]; print { $qseries_fh } "$series\n"; close($qseries_fh); } } sub load_db { my $self = shift; my $pc_applied = $self->get_db_file('applied-patches'); $self->{applied_patches} = [ $self->read_patch_list($pc_applied) ]; } sub save_db { my $self = shift; $self->setup_db(); my $pc_applied = $self->get_db_file('applied-patches'); $self->write_patch_list($pc_applied, $self->{applied_patches}); } sub load_series { my ($self, %opts) = @_; my $series = $self->get_series_file(); $self->{series} = [ $self->read_patch_list($series, %opts) ]; } sub series { my $self = shift; return @{$self->{series}}; } sub applied { my $self = shift; return @{$self->{applied_patches}}; } sub top { my $self = shift; my $count = scalar @{$self->{applied_patches}}; return $self->{applied_patches}[$count - 1] if $count; return; } sub register { my ($self, $patch_name) = @_; return if any { $_ eq $patch_name } @{$self->{series}}; # Add patch to series files. $self->setup_db(); $self->_file_add_line($self->get_series_file(), $patch_name); $self->_file_add_line($self->get_db_file('applied-patches'), $patch_name); $self->load_db(); $self->load_series(); # Ensure quilt meta-data is created and in sync with some trickery: # Reverse-apply the patch, drop .pc/$patch, and re-apply it with the # correct options to recreate the backup files. $self->pop(reverse_apply => 1); $self->push(); } sub unregister { my ($self, $patch_name) = @_; return if none { $_ eq $patch_name } @{$self->{series}}; my $series = $self->get_series_file(); $self->_file_drop_line($series, $patch_name); $self->_file_drop_line($self->get_db_file('applied-patches'), $patch_name); erasedir($self->get_db_file($patch_name)); $self->load_db(); $self->load_series(); # Clean up empty series. unlink $series if -z $series; } sub next { my $self = shift; my $count_applied = scalar @{$self->{applied_patches}}; my $count_series = scalar @{$self->{series}}; return $self->{series}[$count_applied] if ($count_series > $count_applied); return; } sub push { my ($self, %opts) = @_; $opts{verbose} //= 0; $opts{timestamp} //= fs_time($self->{dir}); my $patch = $self->next(); return unless defined $patch; my $path = $self->get_patch_file($patch); my $obj = Dpkg::Source::Patch->new(filename => $path); info(g_('applying %s'), $patch) if $opts{verbose}; eval { $obj->apply($self->{dir}, timestamp => $opts{timestamp}, verbose => $opts{verbose}, force_timestamp => 1, create_dirs => 1, remove_backup => 0, options => [ '-t', '-F', '0', '-N', '-p1', '-u', '-V', 'never', '-E', '-b', '-B', ".pc/$patch/", '--reject-file=-' ]); }; if ($@) { info(g_('the patch has fuzz which is not allowed, or is malformed')); info(g_("if patch '%s' is correctly applied by quilt, use '%s' to update it"), $patch, 'quilt refresh'); info(g_('if the file is present in the unpacked source, make sure it ' . 'is also present in the orig tarball')); $self->restore_quilt_backup_files($patch, %opts); erasedir($self->get_db_file($patch)); die $@; } CORE::push @{$self->{applied_patches}}, $patch; $self->save_db(); } sub pop { my ($self, %opts) = @_; $opts{verbose} //= 0; $opts{timestamp} //= fs_time($self->{dir}); $opts{reverse_apply} //= 0; my $patch = $self->top(); return unless defined $patch; info(g_('unapplying %s'), $patch) if $opts{verbose}; my $backup_dir = $self->get_db_file($patch); if (-d $backup_dir and not $opts{reverse_apply}) { # Use the backup copies to restore $self->restore_quilt_backup_files($patch); } else { # Otherwise reverse-apply the patch my $path = $self->get_patch_file($patch); my $obj = Dpkg::Source::Patch->new(filename => $path); $obj->apply($self->{dir}, timestamp => $opts{timestamp}, verbose => 0, force_timestamp => 1, remove_backup => 0, options => [ '-R', '-t', '-N', '-p1', '-u', '-V', 'never', '-E', '--no-backup-if-mismatch' ]); } erasedir($backup_dir); pop @{$self->{applied_patches}}; $self->save_db(); } sub get_db_version { my $self = shift; my $pc_ver = $self->get_db_file('.version'); if (-f $pc_ver) { open(my $ver_fh, '<', $pc_ver) or syserr(g_('cannot read %s'), $pc_ver); my $version = <$ver_fh>; chomp $version; close($ver_fh); return $version; } return; } sub find_problems { my $self = shift; my $patch_dir = $self->get_patch_file(); if (-e $patch_dir and not -d _) { return sprintf(g_('%s should be a directory or non-existing'), $patch_dir); } my $series = $self->get_series_file(); if (-e $series and not -f _) { return sprintf(g_('%s should be a file or non-existing'), $series); } return; } sub get_series_file { my $self = shift; my $vendor = lc(get_current_vendor() || 'debian'); # Series files are stored alongside patches my $default_series = $self->get_patch_file('series'); my $vendor_series = $self->get_patch_file("$vendor.series"); return $vendor_series if -e $vendor_series; return $default_series; } sub get_db_file { my $self = shift; return File::Spec->catfile($self->{dir}, '.pc', @_); } sub get_db_dir { my $self = shift; return $self->get_db_file(); } sub get_patch_file { my $self = shift; return File::Spec->catfile($self->{dir}, 'debian', 'patches', @_); } sub get_patch_dir { my $self = shift; return $self->get_patch_file(); } ## METHODS BELOW ARE INTERNAL ## sub _file_load { my ($self, $file) = @_; open my $file_fh, '<', $file or syserr(g_('cannot read %s'), $file); my @lines = <$file_fh>; close $file_fh; return @lines; } sub _file_add_line { my ($self, $file, $line) = @_; my @lines; @lines = $self->_file_load($file) if -f $file; CORE::push @lines, $line; chomp @lines; open my $file_fh, '>', $file or syserr(g_('cannot write %s'), $file); print { $file_fh } "$_\n" foreach @lines; close $file_fh; } sub _file_drop_line { my ($self, $file, $re) = @_; my @lines = $self->_file_load($file); open my $file_fh, '>', $file or syserr(g_('cannot write %s'), $file); print { $file_fh } $_ foreach grep { not /^\Q$re\E\s*$/ } @lines; close $file_fh; } sub read_patch_list { my ($self, $file, %opts) = @_; return () if not defined $file or not -f $file; $opts{warn_options} //= 0; my @patches; open(my $series_fh, '<' , $file) or syserr(g_('cannot read %s'), $file); while (defined(my $line = <$series_fh>)) { chomp $line; # Strip leading/trailing spaces $line =~ s/^\s+//; $line =~ s/\s+$//; # Strip comment $line =~ s/(?:^|\s+)#.*$//; next unless $line; if ($line =~ /^(\S+)\s+(.*)$/) { $line = $1; if ($2 ne '-p1') { warning(g_('the series file (%s) contains unsupported ' . "options ('%s', line %s); dpkg-source might " . 'fail when applying patches'), $file, $2, $.) if $opts{warn_options}; } } if ($line =~ m{(^|/)\.\./}) { error(g_('%s contains an insecure path: %s'), $file, $line); } CORE::push @patches, $line; } close($series_fh); return @patches; } sub write_patch_list { my ($self, $series, $patches) = @_; open my $series_fh, '>', $series or syserr(g_('cannot write %s'), $series); foreach my $patch (@{$patches}) { print { $series_fh } "$patch\n"; } close $series_fh; } sub restore_quilt_backup_files { my ($self, $patch, %opts) = @_; my $patch_dir = $self->get_db_file($patch); return unless -d $patch_dir; info(g_('restoring quilt backup files for %s'), $patch) if $opts{verbose}; find({ no_chdir => 1, wanted => sub { return if -d; my $relpath_in_srcpkg = File::Spec->abs2rel($_, $patch_dir); my $target = File::Spec->catfile($self->{dir}, $relpath_in_srcpkg); if (-s) { unlink($target); make_path(dirname($target)); unless (link($_, $target)) { copy($_, $target) or syserr(g_('failed to copy %s to %s'), $_, $target); chmod_if_needed((stat _)[2], $target) or syserr(g_("unable to change permission of '%s'"), $target); } } else { # empty files are "backups" for new files that patch created unlink($target); } } }, $patch_dir); } 1; PK ! qg M@! @! Source/Archive.pmnu �[��� # Copyright © 2008 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Source::Archive; use strict; use warnings; our $VERSION = '0.01'; use Carp; use Errno qw(ENOENT); use File::Temp qw(tempdir); use File::Basename qw(basename); use File::Spec; use File::Find; use Cwd; use Dpkg (); use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::IPC; use Dpkg::Source::Functions qw(erasedir fixperms); use parent qw(Dpkg::Compression::FileHandle); sub create { my ($self, %opts) = @_; $opts{options} //= []; my %spawn_opts; # Possibly run tar from another directory if ($opts{chdir}) { $spawn_opts{chdir} = $opts{chdir}; *$self->{chdir} = $opts{chdir}; } # Redirect input/output appropriately $self->ensure_open('w'); $spawn_opts{to_handle} = $self->get_filehandle(); $spawn_opts{from_pipe} = \*$self->{tar_input}; # Try to use a deterministic mtime. my $mtime = $opts{source_date} // $ENV{SOURCE_DATE_EPOCH} || time; # Call tar creation process $spawn_opts{delete_env} = [ 'TAR_OPTIONS' ]; $spawn_opts{exec} = [ $Dpkg::PROGTAR, '-cf', '-', '--format=gnu', '--sort=name', '--mtime', "\@$mtime", '--clamp-mtime', '--null', '--numeric-owner', '--owner=0', '--group=0', @{$opts{options}}, '-T', '-' ]; *$self->{pid} = spawn(%spawn_opts); *$self->{cwd} = getcwd(); } sub _add_entry { my ($self, $file) = @_; my $cwd = *$self->{cwd}; croak 'call create() first' unless *$self->{tar_input}; $file = $2 if ($file =~ /^\Q$cwd\E\/(.+)$/); # Relative names print({ *$self->{tar_input} } "$file\0") or syserr(g_('write on tar input')); } sub add_file { my ($self, $file) = @_; my $testfile = $file; if (*$self->{chdir}) { $testfile = File::Spec->catfile(*$self->{chdir}, $file); } croak 'add_file() does not handle directories' if not -l $testfile and -d _; $self->_add_entry($file); } sub add_directory { my ($self, $file) = @_; my $testfile = $file; if (*$self->{chdir}) { $testfile = File::Spec->catdir(*$self->{chdir}, $file); } croak 'add_directory() only handles directories' if -l $testfile or not -d _; $self->_add_entry($file); } sub finish { my $self = shift; close(*$self->{tar_input}) or syserr(g_('close on tar input')); wait_child(*$self->{pid}, cmdline => 'tar -cf -'); delete *$self->{pid}; delete *$self->{tar_input}; delete *$self->{cwd}; delete *$self->{chdir}; $self->close(); } sub extract { my ($self, $dest, %opts) = @_; $opts{options} //= []; $opts{in_place} //= 0; $opts{no_fixperms} //= 0; my %spawn_opts = (wait_child => 1); # Prepare destination my $template = basename($self->get_filename()) . '.tmp-extract.XXXXX'; unless (-e $dest) { # Kludge so that realpath works mkdir($dest) or syserr(g_('cannot create directory %s'), $dest); } my $tmp = tempdir($template, DIR => Cwd::realpath("$dest/.."), CLEANUP => 1); $spawn_opts{chdir} = $tmp; # Prepare stuff that handles the input of tar $self->ensure_open('r', delete_sig => [ 'PIPE' ]); $spawn_opts{from_handle} = $self->get_filehandle(); # Call tar extraction process $spawn_opts{delete_env} = [ 'TAR_OPTIONS' ]; $spawn_opts{exec} = [ $Dpkg::PROGTAR, '-xf', '-', '--no-same-permissions', '--no-same-owner', @{$opts{options}} ]; spawn(%spawn_opts); $self->close(); # Fix permissions on extracted files because tar insists on applying # our umask _to the original permissions_ rather than mostly-ignoring # the original permissions. # We still need --no-same-permissions because otherwise tar might # extract directory setgid (which we want inherited, not # extracted); we need --no-same-owner because putting the owner # back is tedious - in particular, correct group ownership would # have to be calculated using mount options and other madness. fixperms($tmp) unless $opts{no_fixperms}; # If we are extracting "in-place" do not remove the destination directory. if ($opts{in_place}) { my $canon_basedir = Cwd::realpath($dest); # On Solaris /dev/null points to /devices/pseudo/mm@0:null. my $canon_devnull = Cwd::realpath('/dev/null'); my $check_symlink = sub { my $pathname = shift; my $canon_pathname = Cwd::realpath($pathname); if (not defined $canon_pathname) { return if $! == ENOENT; syserr(g_("pathname '%s' cannot be canonicalized"), $pathname); } return if $canon_pathname eq $canon_devnull; return if $canon_pathname eq $canon_basedir; return if $canon_pathname =~ m{^\Q$canon_basedir/\E}; warning(g_("pathname '%s' points outside source root (to '%s')"), $pathname, $canon_pathname); }; my $move_in_place = sub { my $relpath = File::Spec->abs2rel($File::Find::name, $tmp); my $destpath = File::Spec->catfile($dest, $relpath); my ($mode, $atime, $mtime); lstat $File::Find::name or syserr(g_('cannot get source pathname %s metadata'), $File::Find::name); ((undef) x 2, $mode, (undef) x 5, $atime, $mtime) = lstat _; my $src_is_dir = -d _; my $dest_exists = 1; if (not lstat $destpath) { if ($! == ENOENT) { $dest_exists = 0; } else { syserr(g_('cannot get target pathname %s metadata'), $destpath); } } my $dest_is_dir = -d _; if ($dest_exists) { if ($dest_is_dir && $src_is_dir) { # Refresh the destination directory attributes with the # ones from the tarball. chmod $mode, $destpath or syserr(g_('cannot change directory %s mode'), $File::Find::name); utime $atime, $mtime, $destpath or syserr(g_('cannot change directory %s times'), $File::Find::name); # We should do nothing, and just walk further tree. return; } elsif ($dest_is_dir) { rmdir $destpath or syserr(g_('cannot remove destination directory %s'), $destpath); } else { $check_symlink->($destpath); unlink $destpath or syserr(g_('cannot remove destination file %s'), $destpath); } } # If we are moving a directory, we do not need to walk it. if ($src_is_dir) { $File::Find::prune = 1; } rename $File::Find::name, $destpath or syserr(g_('cannot move %s to %s'), $File::Find::name, $destpath); }; find({ wanted => $move_in_place, no_chdir => 1, dangling_symlinks => 0, }, $tmp); } else { # Rename extracted directory opendir(my $dir_dh, $tmp) or syserr(g_('cannot opendir %s'), $tmp); my @entries = grep { $_ ne '.' && $_ ne '..' } readdir($dir_dh); closedir($dir_dh); erasedir($dest); if (scalar(@entries) == 1 && ! -l "$tmp/$entries[0]" && -d _) { rename("$tmp/$entries[0]", $dest) or syserr(g_('unable to rename %s to %s'), "$tmp/$entries[0]", $dest); } else { rename($tmp, $dest) or syserr(g_('unable to rename %s to %s'), $tmp, $dest); } } erasedir($tmp); } 1; PK ! op���K �K Source/Package.pmnu �[��� # Copyright © 2008-2011 Raphaël Hertzog <hertzog@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 # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Source::Package; =encoding utf8 =head1 NAME Dpkg::Source::Package - manipulate Debian source packages =head1 DESCRIPTION This module provides 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. =cut use strict; use warnings; our $VERSION = '2.01'; our @EXPORT_OK = qw( get_default_diff_ignore_regex set_default_diff_ignore_regex get_default_tar_ignore_pattern ); 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; use Dpkg::ErrorHandling; use Dpkg::Control; use Dpkg::Checksums; use Dpkg::Version; use Dpkg::Compression; use Dpkg::Path qw(check_files_are_the_same check_directory_traversal); use Dpkg::Vendor qw(run_vendor_hook); use Dpkg::Source::Format; use Dpkg::OpenPGP; my $diff_ignore_default_regex = ' # Ignore general backup files (?:^|/).*~$| # Ignore emacs recovery files (?:^|/)\.#.*$| # Ignore vi swap files (?:^|/)\..*\.sw.$| # Ignore baz-style junk files or directories (?:^|/),,.*(?:$|/.*$)| # File-names that should be ignored (never directories) (?:^|/)(?:DEADJOE|\.arch-inventory|\.(?:bzr|cvs|hg|git|mtn-)ignore)$| # File or directory names that should be ignored (?:^|/)(?:CVS|RCS|\.deps|\{arch\}|\.arch-ids|\.svn| \.hg(?:tags|sigs)?|_darcs|\.git(?:attributes|modules|review)?| \.mailmap|\.shelf|_MTN|\.be|\.bzr(?:\.backup|tags)?)(?:$|/.*$) '; # Take out comments and newlines $diff_ignore_default_regex =~ s/^#.*$//mg; $diff_ignore_default_regex =~ s/\n//sg; no warnings 'qw'; ## no critic (TestingAndDebugging::ProhibitNoWarnings) my @tar_ignore_default_pattern = qw( *.a *.la *.o *.so .*.sw? */*~ ,,* .[#~]* .arch-ids .arch-inventory .be .bzr .bzr.backup .bzr.tags .bzrignore .cvsignore .deps .git .gitattributes .gitignore .gitmodules .gitreview .hg .hgignore .hgsigs .hgtags .mailmap .mtn-ignore .shelf .svn CVS DEADJOE RCS _MTN _darcs {arch} ); ## use critic =head1 FUNCTIONS =over 4 =item $string = get_default_diff_ignore_regex() Returns the default diff ignore regex. =cut sub get_default_diff_ignore_regex { return $diff_ignore_default_regex; } =item set_default_diff_ignore_regex($string) Set a regex as the new default diff ignore regex. =cut sub set_default_diff_ignore_regex { my $regex = shift; $diff_ignore_default_regex = $regex; } =item @array = get_default_tar_ignore_pattern() Returns the default tar ignore pattern, as an array. =cut sub get_default_tar_ignore_pattern { return @tar_ignore_default_pattern; } =back =head1 METHODS =over 4 =item $p = Dpkg::Source::Package->new(%opts, options => {}) 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 B<options> key is a hash ref which supports the following options: =over 8 =item skip_debianization If set to 1, do not apply Debian changes on the extracted source package. =item skip_patches If set to 1, do not apply Debian-specific patches. This options is specific for source packages using format "2.0" and "3.0 (quilt)". =item require_valid_signature If set to 1, the check_signature() method will be stricter and will error out if the signature can't be verified. =item require_strong_checksums If set to 1, the check_checksums() method will be stricter and will error out if there is no strong checksum. =item copy_orig_tarballs If set to 1, the extraction will copy the upstream tarballs next the target directory. This is useful if you want to be able to rebuild the source package after its extraction. =back =cut # 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(), }; bless $self, $class; if (exists $args{options}) { $self->{options} = $args{options}; } if (exists $args{filename}) { $self->initialize($args{filename}); $self->init_options(); } elsif ($args{format}) { $self->{fields}{Format} = $args{format}; $self->upgrade_object_type(0); $self->init_options(); } return $self; } sub init_options { my $self = shift; # Use full ignore list by default # note: this function is not called by V1 packages $self->{options}{diff_ignore_regex} ||= $diff_ignore_default_regex; $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/source/local-.*$'; $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/files(?:\.new)?$'; if (defined $self->{options}{tar_ignore}) { $self->{options}{tar_ignore} = [ @tar_ignore_default_pattern ] unless @{$self->{options}{tar_ignore}}; } else { $self->{options}{tar_ignore} = [ @tar_ignore_default_pattern ]; } push @{$self->{options}{tar_ignore}}, 'debian/source/local-options', 'debian/source/local-patch-header', 'debian/files', 'debian/files.new'; $self->{options}{copy_orig_tarballs} //= 0; # Skip debianization while specific to some formats has an impact # on code common to all formats $self->{options}{skip_debianization} //= 0; $self->{options}{skip_patches} //= 0; # Set default validation checks. $self->{options}{require_valid_signature} //= 0; $self->{options}{require_strong_checksums} //= 0; # Set default compressor for new formats. $self->{options}{compression} //= 'xz'; $self->{options}{comp_level} //= compression_get_property($self->{options}{compression}, 'default_level'); $self->{options}{comp_ext} //= compression_get_property($self->{options}{compression}, 'file_ext'); } sub initialize { my ($self, $filename) = @_; my ($fn, $dir) = fileparse($filename); error(g_('%s is not the name of a file'), $filename) unless $fn; $self->{basedir} = $dir || './'; $self->{filename} = $fn; # Read the fields my $fields = $self->{fields}; $fields->load($filename); $self->{is_signed} = $fields->get_option('is_pgp_signed'); foreach my $f (qw(Source Version Files)) { unless (defined($fields->{$f})) { error(g_('missing critical source control field %s'), $f); } } $self->{checksums}->add_from_control($fields, use_files_for_md5 => 1); $self->upgrade_object_type(0); } sub upgrade_object_type { my ($self, $update_format) = @_; $update_format //= 1; my $format = $self->{fields}{'Format'} // '1.0'; my ($major, $minor, $variant) = $self->{format}->set($format); my $module = "Dpkg::Source::Package::V$major"; $module .= '::' . ucfirst $variant if defined $variant; eval qq{ pop \@INC if \$INC[-1] eq '.'; require $module; \$minor = \$${module}::CURRENT_MINOR_VERSION; }; if ($@) { error(g_("source package format '%s' is not supported: %s"), $format, $@); } if ($update_format) { $self->{format}->set_from_parts($major, $minor, $variant); $self->{fields}{'Format'} = $self->{format}->get(); } $module->prerequisites() if $module->can('prerequisites'); bless $self, $module; } =item $p->get_filename() Returns the filename of the DSC file. =cut sub get_filename { my $self = shift; return $self->{basedir} . $self->{filename}; } =item $p->get_files() Returns the list of files referenced by the source package. The filenames usually do not have any path information. =cut sub get_files { my $self = shift; return $self->{checksums}->get_files(); } =item $p->check_checksums() Verify the checksums embedded in the DSC file. It requires the presence of the other files constituting the source package. If any inconsistency is discovered, it immediately errors out. It will make sure at least one strong checksum is present. If the object has been created with the "require_strong_checksums" option, then any problem will result in a fatal error. =cut sub check_checksums { my $self = shift; my $checksums = $self->{checksums}; my $warn_on_weak = 0; # add_from_file verify the checksums if they are already existing foreach my $file ($checksums->get_files()) { if (not $checksums->has_strong_checksums($file)) { if ($self->{options}{require_strong_checksums}) { error(g_('source package uses only weak checksums')); } else { $warn_on_weak = 1; } } $checksums->add_from_file($self->{basedir} . $file, key => $file); } warning(g_('source package uses only weak checksums')) if $warn_on_weak; } sub get_basename { my ($self, $with_revision) = @_; my $f = $self->{fields}; unless (exists $f->{'Source'} and exists $f->{'Version'}) { error(g_('%s and %s fields are required to compute the source basename'), 'Source', 'Version'); } my $v = Dpkg::Version->new($f->{'Version'}); my $vs = $v->as_string(omit_epoch => 1, omit_revision => !$with_revision); return $f->{'Source'} . '_' . $vs; } sub find_original_tarballs { my ($self, %opts) = @_; $opts{extension} //= compression_get_file_extension_regex(); $opts{include_main} //= 1; $opts{include_supplementary} //= 1; my $basename = $self->get_basename(); my @tar; foreach my $dir ('.', $self->{basedir}, $self->{options}{origtardir}) { next unless defined($dir) and -d $dir; opendir(my $dir_dh, $dir) or syserr(g_('cannot opendir %s'), $dir); push @tar, map { "$dir/$_" } grep { ($opts{include_main} and /^\Q$basename\E\.orig\.tar\.$opts{extension}$/) or ($opts{include_supplementary} and /^\Q$basename\E\.orig-[[:alnum:]-]+\.tar\.$opts{extension}$/) } readdir($dir_dh); closedir($dir_dh); } return @tar; } =item $p->get_upstream_signing_key($dir) Get the filename for the upstream key. =cut sub get_upstream_signing_key { my ($self, $dir) = @_; return "$dir/debian/upstream/signing-key.asc"; } =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 = $self->get_upstream_signing_key($dir); 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'); my %opts = ( require_valid_signature => $self->{options}{require_valid_signature}, ); Dpkg::OpenPGP::import_key($upstream_key, %opts, keyring => $keyring, ); foreach my $asc (@asc) { Dpkg::OpenPGP::verify_signature($asc, %opts, keyrings => [ $keyring ], datafile => $asc =~ s/\.asc$//r, ); } } =item $bool = $p->is_signed() Returns 1 if the DSC files contains an embedded OpenPGP signature. Otherwise returns 0. =cut sub is_signed { my $self = shift; return $self->{is_signed}; } =item $p->check_signature() Implement the same OpenPGP signature check that dpkg-source does. In case of problems, it prints a warning or errors out. If the object has been created with the "require_valid_signature" option, then any problem will result in a fatal error. =cut sub check_signature { my $self = shift; my $dsc = $self->get_filename(); my @keyrings; if (length $ENV{HOME} and -r "$ENV{HOME}/.gnupg/trustedkeys.gpg") { push @keyrings, "$ENV{HOME}/.gnupg/trustedkeys.gpg"; } foreach my $vendor_keyring (run_vendor_hook('package-keyrings')) { if (-r $vendor_keyring) { push @keyrings, $vendor_keyring; } } my %opts = ( keyrings => \@keyrings, require_valid_signature => $self->{options}{require_valid_signature}, ); Dpkg::OpenPGP::verify_signature($dsc, %opts); } sub describe_cmdline_options { return; } sub parse_cmdline_options { my ($self, @opts) = @_; foreach my $option (@opts) { if (not $self->parse_cmdline_option($option)) { warning(g_('%s is not a valid option for %s'), $option, ref $self); } } } sub parse_cmdline_option { return 0; } =item $p->extract($targetdir) Extracts the source package in the target directory $targetdir. Beware that if $targetdir already exists, it will be erased (as long as the no_overwrite_dir option is set). =cut sub extract { my ($self, $newdirectory) = @_; my ($ok, $error) = version_check($self->{fields}{'Version'}); if (not $ok) { if ($self->{options}{ignore_bad_version}) { warning($error); } else { error($error); } } # Copy orig tarballs if ($self->{options}{copy_orig_tarballs}) { my $basename = $self->get_basename(); my ($dirname, $destdir) = fileparse($newdirectory); $destdir ||= './'; my $ext = compression_get_file_extension_regex(); foreach my $orig (grep { /^\Q$basename\E\.orig(-[[:alnum:]-]+)?\.tar\.$ext$/ } $self->get_files()) { my $src = File::Spec->catfile($self->{basedir}, $orig); my $dst = File::Spec->catfile($destdir, $orig); if (not check_files_are_the_same($src, $dst, 1)) { cp($src, $dst) or syserr(g_('cannot copy %s to %s'), $src, $dst); } } } # Try extract $self->do_extract($newdirectory); # Check for directory traversals. if (not $self->{options}{skip_debianization} and not $self->{no_check}) { # We need to add a trailing slash to handle the debian directory # possibly being a symlink. check_directory_traversal($newdirectory, "$newdirectory/debian/"); } # Store format if non-standard so that next build keeps the same format if ($self->{fields}{'Format'} and $self->{fields}{'Format'} ne '1.0' and not $self->{options}{skip_debianization}) { my $srcdir = File::Spec->catdir($newdirectory, 'debian', 'source'); my $format_file = File::Spec->catfile($srcdir, 'format'); unless (-e $format_file) { mkdir($srcdir) unless -e $srcdir; $self->{format}->save($format_file); } } # Make sure debian/rules is executable my $rules = File::Spec->catfile($newdirectory, 'debian', 'rules'); my @s = lstat($rules); if (not scalar(@s)) { unless ($! == ENOENT) { syserr(g_('cannot stat %s'), $rules); } warning(g_('%s does not exist'), $rules) unless $self->{options}{skip_debianization}; } elsif (-f _) { chmod($s[2] | 0111, $rules) or syserr(g_('cannot make %s executable'), $rules); } else { warning(g_('%s is not a plain file'), $rules); } } sub do_extract { croak 'Dpkg::Source::Package does not know how to unpack a ' . 'source package; use one of the subclasses'; } # Function used specifically during creation of a source package sub before_build { my ($self, $dir) = @_; } sub build { my $self = shift; $self->do_build(@_); } sub after_build { my ($self, $dir) = @_; } sub do_build { croak 'Dpkg::Source::Package does not know how to build a ' . 'source package; use one of the subclasses'; } sub can_build { my ($self, $dir) = @_; return (0, 'can_build() has not been overridden'); } sub add_file { my ($self, $filename) = @_; my ($fn, $dir) = fileparse($filename); if ($self->{checksums}->has_file($fn)) { croak "tried to add file '$fn' twice"; } $self->{checksums}->add_from_file($filename, key => $fn); $self->{checksums}->export_to_control($self->{fields}, use_files_for_md5 => 1); } sub commit { my $self = shift; $self->do_commit(@_); } sub do_commit { my ($self, $dir) = @_; info(g_("'%s' is not supported by the source format '%s'"), 'dpkg-source --commit', $self->{fields}{'Format'}); } sub write_dsc { my ($self, %opts) = @_; my $fields = $self->{fields}; foreach my $f (keys %{$opts{override}}) { $fields->{$f} = $opts{override}{$f}; } unless ($opts{nocheck}) { foreach my $f (qw(Source Version Architecture)) { unless (defined($fields->{$f})) { error(g_('missing information for critical output field %s'), $f); } } foreach my $f (qw(Maintainer Standards-Version)) { unless (defined($fields->{$f})) { warning(g_('missing information for output field %s'), $f); } } } foreach my $f (keys %{$opts{remove}}) { delete $fields->{$f}; } my $filename = $opts{filename}; $filename //= $self->get_basename(1) . '.dsc'; open(my $dsc_fh, '>', $filename) or syserr(g_('cannot write %s'), $filename); $fields->apply_substvars($opts{substvars}); $fields->output($dsc_fh); close($dsc_fh); } =back =head1 CHANGES =head2 Version 2.01 (dpkg 1.20.1) New method: get_upstream_signing_key(). =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(). =head2 Version 1.01 (dpkg 1.17.2) New functions: get_default_diff_ignore_regex(), set_default_diff_ignore_regex(), get_default_tar_ignore_pattern() Deprecated variables: $diff_ignore_default_regexp, @tar_ignore_default_pattern =head2 Version 1.00 (dpkg 1.16.1) Mark the module as public. =cut 1; PK ! �=�)� � Source/Functions.pmnu �[��� # Copyright © 2008-2010, 2012-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::Functions; use strict; use warnings; our $VERSION = '0.01'; our @EXPORT_OK = qw( erasedir fixperms chmod_if_needed fs_time is_binary ); use Exporter qw(import); use Errno qw(ENOENT); use Dpkg::ErrorHandling; use Dpkg::Gettext; use Dpkg::IPC; sub erasedir { my $dir = shift; if (not lstat($dir)) { return if $! == ENOENT; syserr(g_('cannot stat directory %s (before removal)'), $dir); } system 'rm', '-rf', '--', $dir; subprocerr("rm -rf $dir") if $?; if (not stat($dir)) { return if $! == ENOENT; syserr(g_("unable to check for removal of directory '%s'"), $dir); } error(g_("rm -rf failed to remove '%s'"), $dir); } sub fixperms { my $dir = shift; my ($mode, $modes_set); # Unfortunately tar insists on applying our umask _to the original # permissions_ rather than mostly-ignoring the original # permissions. We fix it up with chmod -R (which saves us some # work) but we have to construct a u+/- string which is a bit # of a palaver. (Numeric doesn't work because we need [ugo]+X # and [ugo]=<stuff> doesn't work because that unsets sgid on dirs.) $mode = 0777 & ~umask; for my $i (0 .. 2) { $modes_set .= ',' if $i; $modes_set .= qw(u g o)[$i]; for my $j (0 .. 2) { $modes_set .= $mode & (0400 >> ($i * 3 + $j)) ? '+' : '-'; $modes_set .= qw(r w X)[$j]; } } system('chmod', '-R', '--', $modes_set, $dir); 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. # # Use this instead of time() when the timestamp is going to be # used to set file timestamps. This avoids confusion when an # NFS server and NFS client disagree about what time it is. sub fs_time($) { my $file = shift; my $is_temp = 0; if (not -e $file) { open(my $temp_fh, '>', $file) or syserr(g_('cannot write %s')); close($temp_fh); $is_temp = 1; } else { utime(undef, undef, $file) or syserr(g_('cannot change timestamp for %s'), $file); } stat($file) or syserr(g_('cannot read timestamp from %s'), $file); my $mtime = (stat(_))[9]; unlink($file) if $is_temp; return $mtime; } sub is_binary($) { my $file = shift; # 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; return $res >= 0; } 1; PK ! T`dOcF cF Source/Package/V1.pmnu �[��� # Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2008, 2012-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::Package::V1; use strict; use warnings; our $VERSION = '0.01'; use Errno qw(ENOENT); use Cwd; use File::Basename; use File::Temp qw(tempfile); use File::Spec; use Dpkg (); use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Compression; use Dpkg::Source::Archive; use Dpkg::Source::Patch; use Dpkg::Exit qw(push_exit_handler pop_exit_handler); use Dpkg::Source::Functions qw(erasedir); use Dpkg::Source::Package::V3::Native; use Dpkg::OpenPGP; use parent qw(Dpkg::Source::Package); our $CURRENT_MINOR_VERSION = '0'; sub init_options { my $self = shift; # Don't call $self->SUPER::init_options() on purpose, V1.0 has no # ignore by default if ($self->{options}{diff_ignore_regex}) { $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/source/local-.*$'; } else { $self->{options}{diff_ignore_regex} = '(?:^|/)debian/source/local-.*$'; } $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/files(?:\.new)?$'; push @{$self->{options}{tar_ignore}}, 'debian/source/local-options', 'debian/source/local-patch-header', 'debian/files', 'debian/files.new'; $self->{options}{sourcestyle} //= 'X'; $self->{options}{skip_debianization} //= 0; $self->{options}{ignore_bad_version} //= 0; $self->{options}{abort_on_upstream_changes} //= 0; # Set default validation checks. $self->{options}{require_valid_signature} //= 0; $self->{options}{require_strong_checksums} //= 0; # V1.0 only supports gzip compression. $self->{options}{compression} //= 'gzip'; $self->{options}{comp_level} //= compression_get_property('gzip', 'default_level'); $self->{options}{comp_ext} //= compression_get_property('gzip', 'file_ext'); } my @module_cmdline = ( { name => '-sa', help => N_('auto select original source'), when => 'build', }, { name => '-sk', help => N_('use packed original source (unpack and keep)'), when => 'build', }, { name => '-sp', help => N_('use packed original source (unpack and remove)'), when => 'build', }, { name => '-su', help => N_('use unpacked original source (pack and keep)'), when => 'build', }, { name => '-sr', help => N_('use unpacked original source (pack and remove)'), when => 'build', }, { name => '-ss', help => N_('trust packed and unpacked original sources are same'), when => 'build', }, { name => '-sn', help => N_('there is no diff, do main tarfile only'), when => 'build', }, { name => '-sA, -sK, -sP, -sU, -sR', help => N_('like -sa, -sk, -sp, -su, -sr but may overwrite'), when => 'build', }, { name => '--abort-on-upstream-changes', help => N_('abort if generated diff has upstream files changes'), when => 'build', }, { name => '-sp', help => N_('leave original source packed in current directory'), when => 'extract', }, { name => '-su', help => N_('do not copy original source to current directory'), when => 'extract', }, { name => '-sn', help => N_('unpack original source tree too'), when => 'extract', }, { name => '--skip-debianization', help => N_('do not apply debian diff to upstream sources'), when => 'extract', }, ); sub describe_cmdline_options { return @module_cmdline; } sub parse_cmdline_option { my ($self, $opt) = @_; my $o = $self->{options}; if ($opt =~ m/^-s([akpursnAKPUR])$/) { warning(g_('-s%s option overrides earlier -s%s option'), $1, $o->{sourcestyle}) if $o->{sourcestyle} ne 'X'; $o->{sourcestyle} = $1; $o->{copy_orig_tarballs} = 0 if $1 eq 'n'; # Extract option -sn return 1; } elsif ($opt eq '--skip-debianization') { $o->{skip_debianization} = 1; return 1; } elsif ($opt eq '--ignore-bad-version') { $o->{ignore_bad_version} = 1; return 1; } elsif ($opt eq '--abort-on-upstream-changes') { $o->{abort_on_upstream_changes} = 1; return 1; } return 0; } sub do_extract { my ($self, $newdirectory) = @_; my $sourcestyle = $self->{options}{sourcestyle}; my $fields = $self->{fields}; $sourcestyle =~ y/X/p/; unless ($sourcestyle =~ m/[pun]/) { usageerr(g_('source handling style -s%s not allowed with -x'), $sourcestyle); } my $dscdir = $self->{basedir}; my $basename = $self->get_basename(); my $basenamerev = $self->get_basename(1); # V1.0 only supports gzip compression my ($tarfile, $difffile); my $tarsign; foreach my $file ($self->get_files()) { if ($file =~ /^(?:\Q$basename\E\.orig|\Q$basenamerev\E)\.tar\.gz$/) { error(g_('multiple tarfiles in v1.0 source package')) if $tarfile; $tarfile = $file; } elsif ($file =~ /^\Q$basename\E\.orig\.tar\.gz\.asc$/) { $tarsign = $file; } elsif ($file =~ /^\Q$basenamerev\E\.diff\.gz$/) { $difffile = $file; } else { error(g_('unrecognized file for a %s source package: %s'), 'v1.0', $file); } } error(g_('no tarfile in Files field')) unless $tarfile; my $native = $difffile ? 0 : 1; if ($native and ($tarfile =~ /\.orig\.tar\.gz$/)) { warning(g_('native package with .orig.tar')); $native = 0; # V3::Native doesn't handle orig.tar } if ($native) { Dpkg::Source::Package::V3::Native::do_extract($self, $newdirectory); } else { my $expectprefix = $newdirectory; $expectprefix .= '.orig'; if ($self->{options}{no_overwrite_dir} and -e $newdirectory) { error(g_('unpack target exists: %s'), $newdirectory); } else { erasedir($newdirectory); } if (-e $expectprefix) { rename($expectprefix, "$newdirectory.tmp-keep") or syserr(g_("unable to rename '%s' to '%s'"), $expectprefix, "$newdirectory.tmp-keep"); } info(g_('unpacking %s'), $tarfile); my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile"); $tar->extract($expectprefix); if ($sourcestyle =~ /u/) { # -su: keep .orig directory unpacked if (-e "$newdirectory.tmp-keep") { error(g_('unable to keep orig directory (already exists)')); } system('cp', '-ar', '--', $expectprefix, "$newdirectory.tmp-keep"); subprocerr("cp $expectprefix to $newdirectory.tmp-keep") if $?; } rename($expectprefix, $newdirectory) or syserr(g_('failed to rename newly-extracted %s to %s'), $expectprefix, $newdirectory); # rename the copied .orig directory if (-e "$newdirectory.tmp-keep") { rename("$newdirectory.tmp-keep", $expectprefix) or syserr(g_('failed to rename saved %s to %s'), "$newdirectory.tmp-keep", $expectprefix); } } if ($difffile and not $self->{options}{skip_debianization}) { my $patch = "$dscdir$difffile"; info(g_('applying %s'), $difffile); my $patch_obj = Dpkg::Source::Patch->new(filename => $patch); my $analysis = $patch_obj->apply($newdirectory, force_timestamp => 1); my @files = grep { ! m{^\Q$newdirectory\E/debian/} } sort keys %{$analysis->{filepatched}}; info(g_('upstream files that have been modified: %s'), "\n " . join("\n ", @files)) if scalar @files; } } sub can_build { my ($self, $dir) = @_; # As long as we can use gzip, we can do it as we have # native packages as fallback return (0, g_('only supports gzip compression')) unless $self->{options}{compression} eq 'gzip'; return 1; } sub do_build { my ($self, $dir) = @_; my $sourcestyle = $self->{options}{sourcestyle}; my @argv = @{$self->{options}{ARGV}}; my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}}; my $diff_ignore_regex = $self->{options}{diff_ignore_regex}; if (scalar(@argv) > 1) { usageerr(g_('-b takes at most a directory and an orig source ' . 'argument (with v1.0 source package)')); } $sourcestyle =~ y/X/a/; unless ($sourcestyle =~ m/[akpursnAKPUR]/) { usageerr(g_('source handling style -s%s not allowed with -b'), $sourcestyle); } my $sourcepackage = $self->{fields}{'Source'}; my $basenamerev = $self->get_basename(1); my $basename = $self->get_basename(); my $basedirname = $basename; $basedirname =~ s/_/-/; # Try to find a .orig tarball for the package my $origdir = "$dir.orig"; my $origtargz = $self->get_basename() . '.orig.tar.gz'; if (-e $origtargz) { unless (-f $origtargz) { error(g_("packed orig '%s' exists but is not a plain file"), $origtargz); } } else { $origtargz = undef; } if (@argv) { # We have a second-argument <orig-dir> or <orig-targz>, check what it # is to decide the mode to use my $origarg = shift(@argv); if (length($origarg)) { stat($origarg) or syserr(g_('cannot stat orig argument %s'), $origarg); if (-d _) { $origdir = File::Spec->catdir($origarg); $sourcestyle =~ y/aA/rR/; unless ($sourcestyle =~ m/[ursURS]/) { error(g_('orig argument is unpacked but source handling ' . 'style -s%s calls for packed (.orig.tar.<ext>)'), $sourcestyle); } } elsif (-f _) { $origtargz = $origarg; $sourcestyle =~ y/aA/pP/; unless ($sourcestyle =~ m/[kpsKPS]/) { error(g_('orig argument is packed but source handling ' . 'style -s%s calls for unpacked (.orig/)'), $sourcestyle); } } else { error(g_('orig argument %s is not a plain file or directory'), $origarg); } } else { $sourcestyle =~ y/aA/nn/; unless ($sourcestyle =~ m/n/) { error(g_('orig argument is empty (means no orig, no diff) ' . 'but source handling style -s%s wants something'), $sourcestyle); } } } elsif ($sourcestyle =~ m/[aA]/) { # We have no explicit <orig-dir> or <orig-targz>, try to use # a .orig tarball first, then a .orig directory and fall back to # creating a native .tar.gz if ($origtargz) { $sourcestyle =~ y/aA/pP/; # .orig.tar.<ext> } else { if (stat($origdir)) { unless (-d _) { error(g_("unpacked orig '%s' exists but is not a directory"), $origdir); } $sourcestyle =~ y/aA/rR/; # .orig directory } elsif ($! != ENOENT) { syserr(g_("unable to stat putative unpacked orig '%s'"), $origdir); } else { $sourcestyle =~ y/aA/nn/; # Native tar.gz } } } my $v = Dpkg::Version->new($self->{fields}->{'Version'}); if ($sourcestyle =~ m/[kpursKPUR]/) { error(g_('non-native package version does not contain a revision')) if $v->is_native(); } else { # TODO: This will become fatal in the near future. warning(g_('native package version may not have a revision')) unless $v->is_native(); } my ($dirname, $dirbase) = fileparse($dir); if ($dirname ne $basedirname) { warning(g_("source directory '%s' is not <sourcepackage>" . "-<upstreamversion> '%s'"), $dir, $basedirname); } my ($tarname, $tardirname, $tardirbase); my $tarsign; if ($sourcestyle ne 'n') { my ($origdirname, $origdirbase) = fileparse($origdir); if ($origdirname ne "$basedirname.orig") { warning(g_('.orig directory name %s is not <package>' . '-<upstreamversion> (wanted %s)'), $origdirname, "$basedirname.orig"); } $tardirbase = $origdirbase; $tardirname = $origdirname; $tarname = $origtargz || "$basename.orig.tar.gz"; $tarsign = "$tarname.asc"; unless ($tarname =~ /\Q$basename\E\.orig\.tar\.gz/) { warning(g_('.orig.tar name %s is not <package>_<upstreamversion>' . '.orig.tar (wanted %s)'), $tarname, "$basename.orig.tar.gz"); } } if ($sourcestyle eq 'n') { $self->{options}{ARGV} = []; # ensure we have no error Dpkg::Source::Package::V3::Native::do_build($self, $dir); } elsif ($sourcestyle =~ m/[urUR]/) { if (stat($tarname)) { unless ($sourcestyle =~ m/[UR]/) { error(g_("tarfile '%s' already exists, not overwriting, " . 'giving up; use -sU or -sR to override'), $tarname); } } elsif ($! != ENOENT) { syserr(g_("unable to check for existence of '%s'"), $tarname); } info(g_('building %s in %s'), $sourcepackage, $tarname); my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX", DIR => getcwd(), UNLINK => 0); my $tar = Dpkg::Source::Archive->new(filename => $newtar, compression => compression_guess_from_filename($tarname), compression_level => $self->{options}{comp_level}); $tar->create(options => \@tar_ignore, chdir => $tardirbase); $tar->add_directory($tardirname); $tar->finish(); rename($newtar, $tarname) or syserr(g_("unable to rename '%s' (newly created) to '%s'"), $newtar, $tarname); chmod(0666 &~ umask(), $tarname) or syserr(g_("unable to change permission of '%s'"), $tarname); } else { info(g_('building %s using existing %s'), $sourcepackage, $tarname); } 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); info(g_('verifying %s using existing %s'), $tarname, $tarsign); $self->check_original_tarball_signature($dir, $tarsign); } else { my $key = $self->get_upstream_signing_key($dir); if (-e $key) { warning(g_('upstream signing key but no upstream tarball signature')); } } if ($sourcestyle =~ m/[kpKP]/) { if (stat($origdir)) { unless ($sourcestyle =~ m/[KP]/) { error(g_("orig directory '%s' already exists, not overwriting, ". 'giving up; use -sA, -sK or -sP to override'), $origdir); } push_exit_handler(sub { erasedir($origdir) }); erasedir($origdir); pop_exit_handler(); } elsif ($! != ENOENT) { syserr(g_("unable to check for existence of orig directory '%s'"), $origdir); } my $tar = Dpkg::Source::Archive->new(filename => $origtargz); $tar->extract($origdir); } my $ur; # Unrepresentable changes if ($sourcestyle =~ m/[kpursKPUR]/) { my $diffname = "$basenamerev.diff.gz"; info(g_('building %s in %s'), $sourcepackage, $diffname); my ($ndfh, $newdiffgz) = tempfile("$diffname.new.XXXXXX", DIR => getcwd(), UNLINK => 0); push_exit_handler(sub { unlink($newdiffgz) }); my $diff = Dpkg::Source::Patch->new(filename => $newdiffgz, compression => 'gzip', compression_level => $self->{options}{comp_level}); $diff->create(); $diff->add_diff_directory($origdir, $dir, basedirname => $basedirname, diff_ignore_regex => $diff_ignore_regex, options => []); # Force empty set of options to drop the # default -p option $diff->finish() || $ur++; pop_exit_handler(); my $analysis = $diff->analyze($origdir); my @files = grep { ! m{^debian/} } map { s{^[^/]+/+}{}r } sort keys %{$analysis->{filepatched}}; if (scalar @files) { warning(g_('the diff modifies the following upstream files: %s'), "\n " . join("\n ", @files)); info(g_("use the '3.0 (quilt)' format to have separate and " . 'documented changes to upstream files, see dpkg-source(1)')); error(g_('aborting due to --abort-on-upstream-changes')) if $self->{options}{abort_on_upstream_changes}; } rename($newdiffgz, $diffname) or syserr(g_("unable to rename '%s' (newly created) to '%s'"), $newdiffgz, $diffname); chmod(0666 &~ umask(), $diffname) or syserr(g_("unable to change permission of '%s'"), $diffname); $self->add_file($diffname); } if ($sourcestyle =~ m/[prPR]/) { erasedir($origdir); } if ($ur) { errormsg(g_('unrepresentable changes to source')); exit(1); } } 1; PK ! ��J� � Source/Package/V3/Custom.pmnu �[��� # Copyright © 2008 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Source::Package::V3::Custom; use strict; use warnings; our $VERSION = '0.01'; use Dpkg::Gettext; use Dpkg::ErrorHandling; use parent qw(Dpkg::Source::Package); our $CURRENT_MINOR_VERSION = '0'; my @module_cmdline = ( { name => '--target-format=<value>', help => N_('define the format of the generated source package'), when => 'build', } ); sub describe_cmdline_options { return @module_cmdline; } sub parse_cmdline_option { my ($self, $opt) = @_; if ($opt =~ /^--target-format=(.*)$/) { $self->{options}{target_format} = $1; return 1; } return 0; } sub do_extract { error(g_("Format '3.0 (custom)' is only used to create source packages")); } sub can_build { my ($self, $dir) = @_; return (0, g_('no files indicated on command line')) unless scalar(@{$self->{options}{ARGV}}); return 1; } sub do_build { my ($self, $dir) = @_; # Update real target format my $format = $self->{options}{target_format}; error(g_('--target-format option is missing')) unless $format; $self->{fields}{'Format'} = $format; # Add all files foreach my $file (@{$self->{options}{ARGV}}) { $self->add_file($file); } } 1; PK ! I^Z> > Source/Package/V3/Bzr.pmnu �[��� # # bzr support for dpkg-source # # Copyright © 2007 Colin Watson <cjwatson@debian.org>. # Based on Dpkg::Source::Package::V3_0::git, which is: # Copyright © 2007 Joey Hess <joeyh@debian.org>. # Copyright © 2008 Frank Lichtenheld <djpig@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Source::Package::V3::Bzr; use strict; use warnings; our $VERSION = '0.01'; use Cwd; use File::Basename; use File::Find; use File::Temp qw(tempdir); use Dpkg::Gettext; use Dpkg::Compression; use Dpkg::ErrorHandling; use Dpkg::Source::Archive; use Dpkg::Exit qw(push_exit_handler pop_exit_handler); use Dpkg::Path qw(find_command); use Dpkg::Source::Functions qw(erasedir); use parent qw(Dpkg::Source::Package); our $CURRENT_MINOR_VERSION = '0'; sub prerequisites { return 1 if find_command('bzr'); error(g_('cannot unpack bzr-format source package because ' . 'bzr is not in the PATH')); } sub _sanity_check { my $srcdir = shift; if (! -d "$srcdir/.bzr") { error(g_('source directory is not the top directory of a bzr repository (%s/.bzr not present), but Format bzr was specified'), $srcdir); } # Symlinks from .bzr to outside could cause unpack failures, or # point to files they shouldn't, so check for and don't allow. if (-l "$srcdir/.bzr") { error(g_('%s is a symlink'), "$srcdir/.bzr"); } my $abs_srcdir = Cwd::abs_path($srcdir); find(sub { if (-l) { if (Cwd::abs_path(readlink) !~ /^\Q$abs_srcdir\E(?:\/|$)/) { error(g_('%s is a symlink to outside %s'), $File::Find::name, $srcdir); } } }, "$srcdir/.bzr"); return 1; } sub can_build { my ($self, $dir) = @_; return (0, g_("doesn't contain a bzr repository")) unless -d "$dir/.bzr"; return 1; } sub do_build { my ($self, $dir) = @_; my @argv = @{$self->{options}{ARGV}}; # TODO: warn here? #my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}}; my $diff_ignore_regex = $self->{options}{diff_ignore_regex}; $dir =~ s{/+$}{}; # Strip trailing / my ($dirname, $updir) = fileparse($dir); if (scalar(@argv)) { usageerr(g_("-b takes only one parameter with format '%s'"), $self->{fields}{'Format'}); } my $sourcepackage = $self->{fields}{'Source'}; my $basenamerev = $self->get_basename(1); my $basename = $self->get_basename(); my $basedirname = $basename; $basedirname =~ s/_/-/; _sanity_check($dir); my $old_cwd = getcwd(); chdir $dir or syserr(g_("unable to chdir to '%s'"), $dir); local $_; # Check for uncommitted files. # To support dpkg-source -i, remove any ignored files from the # output of bzr status. open(my $bzr_status_fh, '-|', 'bzr', 'status') or subprocerr('bzr status'); my @files; while (<$bzr_status_fh>) { chomp; next unless s/^ +//; if (! length $diff_ignore_regex || ! m/$diff_ignore_regex/o) { push @files, $_; } } close($bzr_status_fh) or syserr(g_('bzr status exited nonzero')); if (@files) { error(g_('uncommitted, not-ignored changes in working directory: %s'), join(' ', @files)); } chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd); my $tmp = tempdir("$dirname.bzr.XXXXXX", DIR => $updir); push_exit_handler(sub { erasedir($tmp) }); my $tardir = "$tmp/$dirname"; system('bzr', 'branch', $dir, $tardir); subprocerr("bzr branch $dir $tardir") if $?; # Remove the working tree. system('bzr', 'remove-tree', $tardir); subprocerr("bzr remove-tree $tardir") if $?; # Some branch metadata files are unhelpful. unlink("$tardir/.bzr/branch/branch-name", "$tardir/.bzr/branch/parent"); # Create the tar file my $debianfile = "$basenamerev.bzr.tar." . $self->{options}{comp_ext}; info(g_('building %s in %s'), $sourcepackage, $debianfile); my $tar = Dpkg::Source::Archive->new(filename => $debianfile, compression => $self->{options}{compression}, compression_level => $self->{options}{comp_level}); $tar->create(chdir => $tmp); $tar->add_directory($dirname); $tar->finish(); erasedir($tmp); pop_exit_handler(); $self->add_file($debianfile); } # Called after a tarball is unpacked, to check out the working copy. sub do_extract { my ($self, $newdirectory) = @_; my $fields = $self->{fields}; my $dscdir = $self->{basedir}; my $basename = $self->get_basename(); my $basenamerev = $self->get_basename(1); my @files = $self->get_files(); if (@files > 1) { error(g_('format v3.0 (bzr) uses only one source file')); } my $tarfile = $files[0]; my $comp_ext_regex = compression_get_file_extension_regex(); if ($tarfile !~ /^\Q$basenamerev\E\.bzr\.tar\.$comp_ext_regex$/) { error(g_('expected %s, got %s'), "$basenamerev.bzr.tar.$comp_ext_regex", $tarfile); } if ($self->{options}{no_overwrite_dir} and -e $newdirectory) { error(g_('unpack target exists: %s'), $newdirectory); } else { erasedir($newdirectory); } # Extract main tarball info(g_('unpacking %s'), $tarfile); my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile"); $tar->extract($newdirectory); _sanity_check($newdirectory); my $old_cwd = getcwd(); chdir($newdirectory) or syserr(g_("unable to chdir to '%s'"), $newdirectory); # Reconstitute the working tree. system('bzr', 'checkout'); subprocerr('bzr checkout') if $?; chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd); } 1; PK ! q� �� � Source/Package/V3/Quilt.pmnu �[��� # Copyright © 2008-2012 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Source::Package::V3::Quilt; use strict; use warnings; our $VERSION = '0.01'; use List::Util qw(any); use File::Spec; use File::Copy; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Version; use Dpkg::Source::Patch; use Dpkg::Source::Functions qw(erasedir chmod_if_needed fs_time); use Dpkg::Source::Quilt; use Dpkg::Exit; # Based on wig&pen implementation use parent qw(Dpkg::Source::Package::V2); our $CURRENT_MINOR_VERSION = '0'; sub init_options { my $self = shift; $self->{options}{single_debian_patch} //= 0; $self->{options}{allow_version_of_quilt_db} //= []; $self->SUPER::init_options(); } my @module_cmdline = ( { name => '--single-debian-patch', help => N_('use a single debianization patch'), when => 'build', }, { name => '--allow-version-of-quilt-db=<version>', help => N_('accept quilt metadata <version> even if unknown'), when => 'build', } ); sub describe_cmdline_options { my $self = shift; my @cmdline = ( $self->SUPER::describe_cmdline_options(), @module_cmdline ); return @cmdline; } sub parse_cmdline_option { my ($self, $opt) = @_; return 1 if $self->SUPER::parse_cmdline_option($opt); if ($opt eq '--single-debian-patch') { $self->{options}{single_debian_patch} = 1; # For backwards compatibility. $self->{options}{auto_commit} = 1; return 1; } elsif ($opt =~ /^--allow-version-of-quilt-db=(.*)$/) { push @{$self->{options}{allow_version_of_quilt_db}}, $1; return 1; } return 0; } sub _build_quilt_object { my ($self, $dir) = @_; return $self->{quilt}{$dir} if exists $self->{quilt}{$dir}; $self->{quilt}{$dir} = Dpkg::Source::Quilt->new($dir); return $self->{quilt}{$dir}; } sub can_build { my ($self, $dir) = @_; my ($code, $msg) = $self->SUPER::can_build($dir); return ($code, $msg) if $code == 0; my $v = Dpkg::Version->new($self->{fields}->{'Version'}); warning (g_('non-native package version does not contain a revision')) if $v->is_native(); my $quilt = $self->_build_quilt_object($dir); $msg = $quilt->find_problems(); return (0, $msg) if $msg; return 1; } sub get_autopatch_name { my $self = shift; if ($self->{options}{single_debian_patch}) { return 'debian-changes'; } else { return 'debian-changes-' . $self->{fields}{'Version'}; } } sub apply_patches { my ($self, $dir, %opts) = @_; if ($opts{usage} eq 'unpack') { $opts{verbose} = 1; } elsif ($opts{usage} eq 'build') { $opts{warn_options} = 1; $opts{verbose} = 0; } my $quilt = $self->_build_quilt_object($dir); $quilt->load_series(%opts) if $opts{warn_options}; # Trigger warnings # Always create the quilt db so that if the maintainer calls quilt to # create a patch, it's stored in the right directory $quilt->save_db(); # Update debian/patches/series symlink if needed to allow quilt usage my $series = $quilt->get_series_file(); my $basename = (File::Spec->splitpath($series))[2]; if ($basename ne 'series') { my $dest = $quilt->get_patch_file('series'); unlink($dest) if -l $dest; unless (-f _) { # Don't overwrite real files symlink($basename, $dest) or syserr(g_("can't create symlink %s"), $dest); } } return unless scalar($quilt->series()); info(g_('using patch list from %s'), "debian/patches/$basename"); if ($opts{usage} eq 'preparation' and $self->{options}{unapply_patches} eq 'auto') { # We're applying the patches in --before-build, remember to unapply # them afterwards in --after-build my $pc_unapply = $quilt->get_db_file('.dpkg-source-unapply'); open(my $unapply_fh, '>', $pc_unapply) or syserr(g_('cannot write %s'), $pc_unapply); close($unapply_fh); } # Apply patches my $pc_applied = $quilt->get_db_file('applied-patches'); $opts{timestamp} = fs_time($pc_applied); if ($opts{skip_auto}) { my $auto_patch = $self->get_autopatch_name(); $quilt->push(%opts) while ($quilt->next() and $quilt->next() ne $auto_patch); } else { $quilt->push(%opts) while $quilt->next(); } } sub unapply_patches { my ($self, $dir, %opts) = @_; my $quilt = $self->_build_quilt_object($dir); $opts{verbose} //= 1; my $pc_applied = $quilt->get_db_file('applied-patches'); my @applied = $quilt->applied(); $opts{timestamp} = fs_time($pc_applied) if @applied; $quilt->pop(%opts) while $quilt->top(); erasedir($quilt->get_db_dir()); } sub prepare_build { my ($self, $dir) = @_; $self->SUPER::prepare_build($dir); # Skip .pc directories of quilt by default and ignore difference # on debian/patches/series symlinks and d/p/.dpkg-source-applied # stamp file created by ourselves my $func = sub { my $pathname = shift; return 1 if $pathname eq 'debian/patches/series' and -l $pathname; return 1 if $pathname =~ /^\.pc(\/|$)/; return 1 if $pathname =~ /$self->{options}{diff_ignore_regex}/; return 0; }; $self->{diff_options}{diff_ignore_func} = $func; } sub do_build { my ($self, $dir) = @_; my $quilt = $self->_build_quilt_object($dir); my $version = $quilt->get_db_version(); if (defined($version) and $version != 2) { if (any { $version eq $_ } @{$self->{options}{allow_version_of_quilt_db}}) { warning(g_('unsupported version of the quilt metadata: %s'), $version); } else { error(g_('unsupported version of the quilt metadata: %s'), $version); } } $self->SUPER::do_build($dir); } sub after_build { my ($self, $dir) = @_; my $quilt = $self->_build_quilt_object($dir); my $pc_unapply = $quilt->get_db_file('.dpkg-source-unapply'); my $opt_unapply = $self->{options}{unapply_patches}; if (($opt_unapply eq 'auto' and -e $pc_unapply) or $opt_unapply eq 'yes') { unlink($pc_unapply); $self->unapply_patches($dir); } } sub check_patches_applied { my ($self, $dir) = @_; my $quilt = $self->_build_quilt_object($dir); my $next = $quilt->next(); return if not defined $next; my $first_patch = File::Spec->catfile($dir, 'debian', 'patches', $next); my $patch_obj = Dpkg::Source::Patch->new(filename => $first_patch); return unless $patch_obj->check_apply($dir, fatal_dupes => 1); $self->apply_patches($dir, usage => 'preparation', verbose => 1); } sub register_patch { my ($self, $dir, $tmpdiff, $patch_name) = @_; my $quilt = $self->_build_quilt_object($dir); my $patch = $quilt->get_patch_file($patch_name); if (-s $tmpdiff) { copy($tmpdiff, $patch) or syserr(g_('failed to copy %s to %s'), $tmpdiff, $patch); chmod_if_needed(0666 & ~ umask(), $patch) or syserr(g_("unable to change permission of '%s'"), $patch); } elsif (-e $patch) { unlink($patch) or syserr(g_('cannot remove %s'), $patch); } if (-e $patch) { # Add patch to series file $quilt->register($patch_name); } else { # Remove auto_patch from series $quilt->unregister($patch_name); } return $patch; } 1; PK ! _�$�8 8 Source/Package/V3/Git.pmnu �[��� # # git support for dpkg-source # # Copyright © 2007,2010 Joey Hess <joeyh@debian.org>. # Copyright © 2008 Frank Lichtenheld <djpig@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Source::Package::V3::Git; use strict; use warnings; our $VERSION = '0.02'; use Cwd qw(abs_path getcwd); use File::Basename; use File::Temp qw(tempdir); use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Exit qw(push_exit_handler pop_exit_handler); use Dpkg::Path qw(find_command); use Dpkg::Source::Functions qw(erasedir); use parent qw(Dpkg::Source::Package); our $CURRENT_MINOR_VERSION = '0'; # Remove variables from the environment that might cause git to do # something unexpected. delete $ENV{GIT_DIR}; delete $ENV{GIT_INDEX_FILE}; delete $ENV{GIT_OBJECT_DIRECTORY}; delete $ENV{GIT_ALTERNATE_OBJECT_DIRECTORIES}; delete $ENV{GIT_WORK_TREE}; sub prerequisites { return 1 if find_command('git'); error(g_('cannot unpack git-format source package because ' . 'git is not in the PATH')); } sub _sanity_check { my $srcdir = shift; if (! -d "$srcdir/.git") { error(g_('source directory is not the top directory of a git ' . 'repository (%s/.git not present), but Format git was ' . 'specified'), $srcdir); } if (-s "$srcdir/.gitmodules") { error(g_('git repository %s uses submodules; this is not yet supported'), $srcdir); } return 1; } my @module_cmdline = ( { name => '--git-ref=<ref>', help => N_('specify a git <ref> to include in the git bundle'), when => 'build', }, { name => '--git-depth=<number>', help => N_('create a shallow clone with <number> depth'), when => 'build', } ); sub describe_cmdline_options { my $self = shift; my @cmdline = ( $self->SUPER::describe_cmdline_options(), @module_cmdline ); return @cmdline; } sub parse_cmdline_option { my ($self, $opt) = @_; return 1 if $self->SUPER::parse_cmdline_option($opt); if ($opt =~ /^--git-ref=(.*)$/) { push @{$self->{options}{git_ref}}, $1; return 1; } elsif ($opt =~ /^--git-depth=(\d+)$/) { $self->{options}{git_depth} = $1; return 1; } return 0; } sub can_build { my ($self, $dir) = @_; return (0, g_("doesn't contain a git repository")) unless -d "$dir/.git"; return 1; } sub do_build { my ($self, $dir) = @_; my $diff_ignore_regex = $self->{options}{diff_ignore_regex}; $dir =~ s{/+$}{}; # Strip trailing / my ($dirname, $updir) = fileparse($dir); my $basenamerev = $self->get_basename(1); _sanity_check($dir); my $old_cwd = getcwd(); chdir $dir or syserr(g_("unable to chdir to '%s'"), $dir); # Check for uncommitted files. # To support dpkg-source -i, get a list of files # equivalent to the ones git status finds, and remove any # ignored files from it. my @ignores = '--exclude-per-directory=.gitignore'; my $core_excludesfile = qx(git config --get core.excludesfile); chomp $core_excludesfile; if (length $core_excludesfile && -e $core_excludesfile) { push @ignores, "--exclude-from=$core_excludesfile"; } if (-e '.git/info/exclude') { push @ignores, '--exclude-from=.git/info/exclude'; } open(my $git_ls_files_fh, '-|', 'git', 'ls-files', '--modified', '--deleted', '-z', '--others', @ignores) or subprocerr('git ls-files'); my @files; { local $_; local $/ = "\0"; while (<$git_ls_files_fh>) { chomp; if (! length $diff_ignore_regex || ! m/$diff_ignore_regex/o) { push @files, $_; } } } close($git_ls_files_fh) or syserr(g_('git ls-files exited nonzero')); if (@files) { error(g_('uncommitted, not-ignored changes in working directory: %s'), join(' ', @files)); } # If a depth was specified, need to create a shallow clone and # bundle that. my $tmp; my $shallowfile; if ($self->{options}{git_depth}) { chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd); $tmp = tempdir("$dirname.git.XXXXXX", DIR => $updir); push_exit_handler(sub { erasedir($tmp) }); my $clone_dir = "$tmp/repo.git"; # file:// is needed to avoid local cloning, which does not # create a shallow clone. info(g_('creating shallow clone with depth %s'), $self->{options}{git_depth}); system('git', 'clone', '--depth=' . $self->{options}{git_depth}, '--quiet', '--bare', 'file://' . abs_path($dir), $clone_dir); subprocerr('git clone') if $?; chdir($clone_dir) or syserr(g_("unable to chdir to '%s'"), $clone_dir); $shallowfile = "$basenamerev.gitshallow"; system('cp', '-f', 'shallow', "$old_cwd/$shallowfile"); subprocerr('cp shallow') if $?; } # Create the git bundle. my $bundlefile = "$basenamerev.git"; my @bundle_arg=$self->{options}{git_ref} ? (@{$self->{options}{git_ref}}) : '--all'; info(g_('bundling: %s'), join(' ', @bundle_arg)); system('git', 'bundle', 'create', "$old_cwd/$bundlefile", @bundle_arg, 'HEAD', # ensure HEAD is included no matter what '--', # avoids ambiguity error when referring to eg, a debian branch ); subprocerr('git bundle') if $?; chdir $old_cwd or syserr(g_("unable to chdir to '%s'"), $old_cwd); if (defined $tmp) { erasedir($tmp); pop_exit_handler(); } $self->add_file($bundlefile); if (defined $shallowfile) { $self->add_file($shallowfile); } } sub do_extract { my ($self, $newdirectory) = @_; my $fields = $self->{fields}; my $dscdir = $self->{basedir}; my $basenamerev = $self->get_basename(1); my @files = $self->get_files(); my ($bundle, $shallow); foreach my $file (@files) { if ($file =~ /^\Q$basenamerev\E\.git$/) { if (! defined $bundle) { $bundle = $file; } else { error(g_('format v3.0 (git) uses only one .git file')); } } elsif ($file =~ /^\Q$basenamerev\E\.gitshallow$/) { if (! defined $shallow) { $shallow = $file; } else { error(g_('format v3.0 (git) uses only one .gitshallow file')); } } else { error(g_('format v3.0 (git) unknown file: %s', $file)); } } if (! defined $bundle) { error(g_('format v3.0 (git) expected %s'), "$basenamerev.git"); } if ($self->{options}{no_overwrite_dir} and -e $newdirectory) { error(g_('unpack target exists: %s'), $newdirectory); } else { erasedir($newdirectory); } # Extract git bundle. info(g_('cloning %s'), $bundle); system('git', 'clone', '--quiet', $dscdir . $bundle, $newdirectory); subprocerr('git bundle') if $?; if (defined $shallow) { # Move shallow info file into place, so git does not # try to follow parents of shallow refs. info(g_('setting up shallow clone')); system('cp', '-f', $dscdir . $shallow, "$newdirectory/.git/shallow"); subprocerr('cp') if $?; } _sanity_check($newdirectory); } 1; PK ! U� �� � Source/Package/V3/Native.pmnu �[��� # Copyright © 2008 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Source::Package::V3::Native; use strict; use warnings; our $VERSION = '0.01'; use Cwd; use File::Basename; use File::Temp qw(tempfile); use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Compression; use Dpkg::Exit qw(push_exit_handler pop_exit_handler); use Dpkg::Version; use Dpkg::Source::Archive; use Dpkg::Source::Functions qw(erasedir); use parent qw(Dpkg::Source::Package); our $CURRENT_MINOR_VERSION = '0'; sub do_extract { my ($self, $newdirectory) = @_; my $sourcestyle = $self->{options}{sourcestyle}; my $fields = $self->{fields}; my $dscdir = $self->{basedir}; my $basename = $self->get_basename(); my $basenamerev = $self->get_basename(1); my $tarfile; my $comp_ext_regex = compression_get_file_extension_regex(); foreach my $file ($self->get_files()) { if ($file =~ /^\Q$basenamerev\E\.tar\.$comp_ext_regex$/) { error(g_('multiple tarfiles in native source package')) if $tarfile; $tarfile = $file; } else { error(g_('unrecognized file for a native source package: %s'), $file); } } error(g_('no tarfile in Files field')) unless $tarfile; if ($self->{options}{no_overwrite_dir} and -e $newdirectory) { error(g_('unpack target exists: %s'), $newdirectory); } else { erasedir($newdirectory); } info(g_('unpacking %s'), $tarfile); my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile"); $tar->extract($newdirectory); } sub can_build { my ($self, $dir) = @_; my $v = Dpkg::Version->new($self->{fields}->{'Version'}); warning (g_('native package version may not have a revision')) unless $v->is_native(); return 1; } sub do_build { my ($self, $dir) = @_; my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}}; my @argv = @{$self->{options}{ARGV}}; if (scalar(@argv)) { usageerr(g_("-b takes only one parameter with format '%s'"), $self->{fields}{'Format'}); } my $sourcepackage = $self->{fields}{'Source'}; my $basenamerev = $self->get_basename(1); my $tarname = "$basenamerev.tar." . $self->{options}{comp_ext}; info(g_('building %s in %s'), $sourcepackage, $tarname); my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX", DIR => getcwd(), UNLINK => 0); push_exit_handler(sub { unlink($newtar) }); my ($dirname, $dirbase) = fileparse($dir); my $tar = Dpkg::Source::Archive->new(filename => $newtar, compression => compression_guess_from_filename($tarname), compression_level => $self->{options}{comp_level}); $tar->create(options => \@tar_ignore, chdir => $dirbase); $tar->add_directory($dirname); $tar->finish(); rename($newtar, $tarname) or syserr(g_("unable to rename '%s' (newly created) to '%s'"), $newtar, $tarname); pop_exit_handler(); chmod(0666 &~ umask(), $tarname) or syserr(g_("unable to change permission of '%s'"), $tarname); $self->add_file($tarname); } 1; PK ! D� * k k Source/Package/V2.pmnu �[��� # 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::Package::V2; use strict; use warnings; our $VERSION = '0.01'; use List::Util qw(first); use Cwd; use File::Basename; use File::Temp qw(tempfile tempdir); use File::Path qw(make_path); use File::Spec; use File::Find; use File::Copy; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::File; 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 chmod_if_needed fs_time); use Dpkg::Vendor qw(run_vendor_hook); use Dpkg::Control; use Dpkg::Changelog::Parse; use Dpkg::OpenPGP; use parent qw(Dpkg::Source::Package); our $CURRENT_MINOR_VERSION = '0'; sub init_options { my $self = shift; $self->SUPER::init_options(); $self->{options}{include_removal} //= 0; $self->{options}{include_timestamp} //= 0; $self->{options}{include_binaries} //= 0; $self->{options}{preparation} //= 1; $self->{options}{skip_patches} //= 0; $self->{options}{unapply_patches} //= 'auto'; $self->{options}{skip_debianization} //= 0; $self->{options}{create_empty_orig} //= 0; $self->{options}{auto_commit} //= 0; $self->{options}{ignore_bad_version} //= 0; } my @module_cmdline = ( { name => '--include-removal', help => N_('include removed files in the patch'), when => 'build', }, { name => '--include-timestamp', help => N_('include timestamp in the patch'), when => 'build', }, { name => '--include-binaries', help => N_('include binary files in the tarball'), when => 'build', }, { name => '--no-preparation', help => N_('do not prepare build tree by applying patches'), when => 'build', }, { name => '--no-unapply-patches', help => N_('do not unapply patches if previously applied'), when => 'build', }, { name => '--unapply-patches', help => N_('unapply patches if previously applied (default)'), when => 'build', }, { name => '--create-empty-orig', help => N_('create an empty original tarball if missing'), when => 'build', }, { name => '--abort-on-upstream-changes', help => N_('abort if generated diff has upstream files changes'), when => 'build', }, { name => '--auto-commit', help => N_('record generated patches, instead of aborting'), when => 'build', }, { name => '--skip-debianization', help => N_('do not extract debian tarball into upstream sources'), when => 'extract', }, { name => '--skip-patches', help => N_('do not apply patches at the end of the extraction'), when => 'extract', } ); sub describe_cmdline_options { return @module_cmdline; } sub parse_cmdline_option { my ($self, $opt) = @_; if ($opt eq '--include-removal') { $self->{options}{include_removal} = 1; return 1; } elsif ($opt eq '--include-timestamp') { $self->{options}{include_timestamp} = 1; return 1; } elsif ($opt eq '--include-binaries') { $self->{options}{include_binaries} = 1; return 1; } elsif ($opt eq '--no-preparation') { $self->{options}{preparation} = 0; return 1; } elsif ($opt eq '--skip-patches') { $self->{options}{skip_patches} = 1; return 1; } elsif ($opt eq '--unapply-patches') { $self->{options}{unapply_patches} = 'yes'; return 1; } elsif ($opt eq '--no-unapply-patches') { $self->{options}{unapply_patches} = 'no'; return 1; } elsif ($opt eq '--skip-debianization') { $self->{options}{skip_debianization} = 1; return 1; } elsif ($opt eq '--create-empty-orig') { $self->{options}{create_empty_orig} = 1; return 1; } elsif ($opt eq '--abort-on-upstream-changes') { $self->{options}{auto_commit} = 0; return 1; } elsif ($opt eq '--auto-commit') { $self->{options}{auto_commit} = 1; return 1; } elsif ($opt eq '--ignore-bad-version') { $self->{options}{ignore_bad_version} = 1; return 1; } return 0; } sub do_extract { my ($self, $newdirectory) = @_; my $fields = $self->{fields}; my $dscdir = $self->{basedir}; my $basename = $self->get_basename(); my $basenamerev = $self->get_basename(1); my ($tarfile, $debianfile, %addonfile, %seen); my ($tarsign, %addonsign); my $re_ext = compression_get_file_extension_regex(); foreach my $file ($self->get_files()) { my $uncompressed = $file; $uncompressed =~ s/\.$re_ext$/.*/; $uncompressed =~ s/\.$re_ext\.asc$/.*.asc/; error(g_('duplicate files in %s source package: %s'), 'v2.0', $uncompressed) if $seen{$uncompressed}; $seen{$uncompressed} = 1; if ($file =~ /^\Q$basename\E\.orig\.tar\.$re_ext$/) { $tarfile = $file; } elsif ($file =~ /^\Q$basename\E\.orig\.tar\.$re_ext\.asc$/) { $tarsign = $file; } elsif ($file =~ /^\Q$basename\E\.orig-([[:alnum:]-]+)\.tar\.$re_ext$/) { $addonfile{$1} = $file; } elsif ($file =~ /^\Q$basename\E\.orig-([[:alnum:]-]+)\.tar\.$re_ext\.asc$/) { $addonsign{$1} = $file; } elsif ($file =~ /^\Q$basenamerev\E\.debian\.tar\.$re_ext$/) { $debianfile = $file; } else { error(g_('unrecognized file for a %s source package: %s'), 'v2.0', $file); } } unless ($tarfile and $debianfile) { error(g_('missing orig.tar or debian.tar file in v2.0 source package')); } if ($tarsign and $tarfile ne substr $tarsign, 0, -4) { error(g_('mismatched orig.tar %s for signature %s in source package'), $tarfile, $tarsign); } foreach my $name (keys %addonsign) { error(g_('missing addon orig.tar for signature %s in source package'), $addonsign{$name}) if not exists $addonfile{$name}; error(g_('mismatched addon orig.tar %s for signature %s in source package'), $addonfile{$name}, $addonsign{$name}) if $addonfile{$name} ne substr $addonsign{$name}, 0, -4; } if ($self->{options}{no_overwrite_dir} and -e $newdirectory) { error(g_('unpack target exists: %s'), $newdirectory); } else { erasedir($newdirectory); } # Extract main tarball info(g_('unpacking %s'), $tarfile); my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile"); $tar->extract($newdirectory, no_fixperms => 1, options => [ '--anchored', '--no-wildcards-match-slash', '--exclude', '*/.pc', '--exclude', '.pc' ]); # The .pc exclusion is only needed for 3.0 (quilt) and to avoid # having an upstream tarball provide a directory with symlinks # that would be blindly followed when applying the patches # Extract additional orig tarballs foreach my $subdir (sort keys %addonfile) { my $file = $addonfile{$subdir}; info(g_('unpacking %s'), $file); # If the pathname is an empty directory, just silently remove it, as # it might be part of a git repository, as a submodule for example. rmdir "$newdirectory/$subdir"; if (-e "$newdirectory/$subdir") { warning(g_("required removal of '%s' installed by original tarball"), $subdir); erasedir("$newdirectory/$subdir"); } $tar = Dpkg::Source::Archive->new(filename => "$dscdir$file"); $tar->extract("$newdirectory/$subdir", no_fixperms => 1); } # Stop here if debianization is not wanted return if $self->{options}{skip_debianization}; # Extract debian tarball after removing the debian directory info(g_('unpacking %s'), $debianfile); erasedir("$newdirectory/debian"); $tar = Dpkg::Source::Archive->new(filename => "$dscdir$debianfile"); $tar->extract($newdirectory, in_place => 1); # Apply patches (in a separate method as it might be overridden) $self->apply_patches($newdirectory, usage => 'unpack') unless $self->{options}{skip_patches}; } sub get_autopatch_name { return 'zz_debian-diff-auto'; } sub _get_patches { my ($self, $dir, %opts) = @_; $opts{skip_auto} //= 0; my @patches; my $pd = "$dir/debian/patches"; my $auto_patch = $self->get_autopatch_name(); if (-d $pd) { opendir(my $dir_dh, $pd) or syserr(g_('cannot opendir %s'), $pd); foreach my $patch (sort readdir($dir_dh)) { # patches match same rules as run-parts next unless $patch =~ /^[\w-]+$/ and -f "$pd/$patch"; next if $opts{skip_auto} and $patch eq $auto_patch; push @patches, $patch; } closedir($dir_dh); } return @patches; } sub apply_patches { my ($self, $dir, %opts) = @_; $opts{skip_auto} //= 0; my @patches = $self->_get_patches($dir, %opts); return unless scalar(@patches); my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied'); open(my $applied_fh, '>', $applied) or syserr(g_('cannot write %s'), $applied); print { $applied_fh } "# During $opts{usage}\n"; my $timestamp = fs_time($applied); foreach my $patch ($self->_get_patches($dir, %opts)) { my $path = File::Spec->catfile($dir, 'debian', 'patches', $patch); info(g_('applying %s'), $patch) unless $opts{skip_auto}; my $patch_obj = Dpkg::Source::Patch->new(filename => $path); $patch_obj->apply($dir, force_timestamp => 1, timestamp => $timestamp, add_options => [ '-E' ]); print { $applied_fh } "$patch\n"; } close($applied_fh); } sub unapply_patches { my ($self, $dir, %opts) = @_; my @patches = reverse($self->_get_patches($dir, %opts)); return unless scalar(@patches); my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied'); my $timestamp = fs_time($applied); foreach my $patch (@patches) { my $path = File::Spec->catfile($dir, 'debian', 'patches', $patch); info(g_('unapplying %s'), $patch) unless $opts{quiet}; my $patch_obj = Dpkg::Source::Patch->new(filename => $path); $patch_obj->apply($dir, force_timestamp => 1, verbose => 0, timestamp => $timestamp, add_options => [ '-E', '-R' ]); } unlink($applied); } sub _upstream_tarball_template { my $self = shift; my $ext = '{' . join(',', sort map { compression_get_property($_, 'file_ext') } compression_get_list()) . '}'; return '../' . $self->get_basename() . ".orig.tar.$ext"; } sub can_build { my ($self, $dir) = @_; return 1 if $self->find_original_tarballs(include_supplementary => 0); return 1 if $self->{options}{create_empty_orig} and $self->find_original_tarballs(include_main => 0); return (0, sprintf(g_('no upstream tarball found at %s'), $self->_upstream_tarball_template())); } sub before_build { my ($self, $dir) = @_; $self->check_patches_applied($dir) if $self->{options}{preparation}; } sub after_build { my ($self, $dir) = @_; my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied'); my $reason = ''; if (-e $applied) { open(my $applied_fh, '<', $applied) or syserr(g_('cannot read %s'), $applied); $reason = <$applied_fh>; close($applied_fh); } my $opt_unapply = $self->{options}{unapply_patches}; if (($opt_unapply eq 'auto' and $reason =~ /^# During preparation/) or $opt_unapply eq 'yes') { $self->unapply_patches($dir); } } sub prepare_build { my ($self, $dir) = @_; $self->{diff_options} = { diff_ignore_regex => $self->{options}{diff_ignore_regex} . '|(^|/)debian/patches/.dpkg-source-applied$', include_removal => $self->{options}{include_removal}, include_timestamp => $self->{options}{include_timestamp}, use_dev_null => 1, }; push @{$self->{options}{tar_ignore}}, 'debian/patches/.dpkg-source-applied'; $self->check_patches_applied($dir) if $self->{options}{preparation}; if ($self->{options}{create_empty_orig} and not $self->find_original_tarballs(include_supplementary => 0)) { # No main orig.tar, create a dummy one my $filename = $self->get_basename() . '.orig.tar.' . $self->{options}{comp_ext}; my $tar = Dpkg::Source::Archive->new(filename => $filename, compression_level => $self->{options}{comp_level}); $tar->create(); $tar->finish(); } } sub check_patches_applied { my ($self, $dir) = @_; my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied'); unless (-e $applied) { info(g_('patches are not applied, applying them now')); $self->apply_patches($dir, usage => 'preparation'); } } sub _generate_patch { my ($self, $dir, %opts) = @_; my ($dirname, $updir) = fileparse($dir); my $basedirname = $self->get_basename(); $basedirname =~ s/_/-/; # Identify original tarballs my ($tarfile, %addonfile); my $comp_ext_regex = compression_get_file_extension_regex(); my @origtarfiles; my @origtarsigns; foreach my $file (sort $self->find_original_tarballs()) { if ($file =~ /\.orig\.tar\.$comp_ext_regex$/) { if (defined($tarfile)) { error(g_('several orig.tar files found (%s and %s) but only ' . 'one is allowed'), $tarfile, $file); } $tarfile = $file; } elsif ($file =~ /\.orig-([[:alnum:]-]+)\.tar\.$comp_ext_regex$/) { $addonfile{$1} = $file; } 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") } } error(g_('no upstream tarball found at %s'), $self->_upstream_tarball_template()) unless $tarfile; if ($opts{usage} eq 'build') { foreach my $origtarfile (@origtarfiles) { info(g_('building %s using existing %s'), $self->{fields}{'Source'}, $origtarfile); } if (@origtarsigns) { $self->check_original_tarball_signature($dir, @origtarsigns); } else { my $key = $self->get_upstream_signing_key($dir); if (-e $key) { warning(g_('upstream signing key but no upstream tarball signature')); } } } # Unpack a second copy for comparison my $tmp = tempdir("$dirname.orig.XXXXXX", DIR => $updir); push_exit_handler(sub { erasedir($tmp) }); # Extract main tarball my $tar = Dpkg::Source::Archive->new(filename => $tarfile); $tar->extract($tmp); # Extract additional orig tarballs foreach my $subdir (keys %addonfile) { my $file = $addonfile{$subdir}; $tar = Dpkg::Source::Archive->new(filename => $file); $tar->extract("$tmp/$subdir"); } # Copy over the debian directory erasedir("$tmp/debian"); system('cp', '-a', '--', "$dir/debian", "$tmp/"); subprocerr(g_('copy of the debian directory')) if $?; # Apply all patches except the last automatic one $opts{skip_auto} //= 0; $self->apply_patches($tmp, skip_auto => $opts{skip_auto}, usage => 'build'); # Create a patch my ($difffh, $tmpdiff) = tempfile($self->get_basename(1) . '.diff.XXXXXX', TMPDIR => 1, UNLINK => 0); push_exit_handler(sub { unlink($tmpdiff) }); my $diff = Dpkg::Source::Patch->new(filename => $tmpdiff, compression => 'none'); $diff->create(); if ($opts{header_from} and -e $opts{header_from}) { my $header_from = Dpkg::Source::Patch->new( filename => $opts{header_from}); my $analysis = $header_from->analyze($dir, verbose => 0); $diff->set_header($analysis->{patchheader}); } else { $diff->set_header($self->_get_patch_header($dir)); } $diff->add_diff_directory($tmp, $dir, basedirname => $basedirname, %{$self->{diff_options}}, handle_binary_func => $opts{handle_binary}, order_from => $opts{order_from}); error(g_('unrepresentable changes to source')) if not $diff->finish(); if (-s $tmpdiff) { info(g_('local changes detected, the modified files are:')); my $analysis = $diff->analyze($dir, verbose => 0); foreach my $fn (sort keys %{$analysis->{filepatched}}) { print " $fn\n"; } } # Remove the temporary directory erasedir($tmp); pop_exit_handler(); pop_exit_handler(); return $tmpdiff; } sub do_build { my ($self, $dir) = @_; my @argv = @{$self->{options}{ARGV}}; if (scalar(@argv)) { usageerr(g_("-b takes only one parameter with format '%s'"), $self->{fields}{'Format'}); } $self->prepare_build($dir); my $include_binaries = $self->{options}{include_binaries}; my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}}; my $sourcepackage = $self->{fields}{'Source'}; my $basenamerev = $self->get_basename(1); # Check if the debian directory contains unwanted binary files 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 { my ($self, $old, $new, %opts) = @_; my $file = $opts{filename}; $binaryfiles->new_binary_found($file); unless ($include_binaries or $binaryfiles->binary_is_allowed($file)) { errormsg(g_('cannot represent change to %s: %s'), $file, g_('binary file contents changed')); errormsg(g_('add %s in debian/source/include-binaries if you want ' . 'to store the modified binary in the debian tarball'), $file); $self->register_error(); } }; # Create a patch my $autopatch = File::Spec->catfile($dir, 'debian', 'patches', $self->get_autopatch_name()); my $tmpdiff = $self->_generate_patch($dir, order_from => $autopatch, header_from => $autopatch, handle_binary => $handle_binary, skip_auto => $self->{options}{auto_commit}, usage => 'build'); unless (-z $tmpdiff or $self->{options}{auto_commit}) { info(g_('Hint: make sure the version in debian/changelog matches ' . 'the unpacked source tree')); info(g_('you can integrate the local changes with %s'), 'dpkg-source --commit'); error(g_('aborting due to unexpected upstream changes, see %s'), $tmpdiff); } push_exit_handler(sub { unlink($tmpdiff) }); $binaryfiles->update_debian_source_include_binaries() if $include_binaries; # Install the diff as the new autopatch if ($self->{options}{auto_commit}) { make_path(File::Spec->catdir($dir, 'debian', 'patches')); $autopatch = $self->register_patch($dir, $tmpdiff, $self->get_autopatch_name()); info(g_('local changes have been recorded in a new patch: %s'), $autopatch) if -e $autopatch; rmdir(File::Spec->catdir($dir, 'debian', 'patches')); # No check on purpose } unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff); pop_exit_handler(); # Create the debian.tar my $debianfile = "$basenamerev.debian.tar." . $self->{options}{comp_ext}; info(g_('building %s in %s'), $sourcepackage, $debianfile); my $tar = Dpkg::Source::Archive->new(filename => $debianfile, compression_level => $self->{options}{comp_level}); $tar->create(options => \@tar_ignore, chdir => $dir); $tar->add_directory('debian'); foreach my $binary ($binaryfiles->get_seen_binaries()) { $tar->add_file($binary) unless $binary =~ m{^debian/}; } $tar->finish(); $self->add_file($debianfile); } 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'); } if (-f $ph) { 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; my $header = Dpkg::Control->new(type => CTRL_UNKNOWN); $header->{'Description'} = "<short summary of the patch>\n"; $header->{'Description'} .= "TODO: Put a short summary on the line above and replace this paragraph with a longer explanation of this change. Complete the meta-information with other relevant fields (see below for details). To make it easier, the information below has been extracted from the changelog. Adjust it or drop it.\n"; $header->{'Description'} .= $ch_info->{'Changes'} . "\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--- The information above should follow the Patch Tagging Guidelines, please checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here are templates for supplementary fields that you might want to add: Origin: <vendor|upstream|other>, <url of original patch> Bug: <url in upstream bugtracker> Bug-Debian: https://bugs.debian.org/<bugnumber> Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber> Forwarded: <no|not-needed|url proving that it has been forwarded> Reviewed-By: <name and email of someone who approved the patch> Last-Update: $yyyy_mm_dd\n\n"; return $text; } sub register_patch { my ($self, $dir, $patch_file, $patch_name) = @_; my $patch = File::Spec->catfile($dir, 'debian', 'patches', $patch_name); if (-s $patch_file) { copy($patch_file, $patch) or syserr(g_('failed to copy %s to %s'), $patch_file, $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) or syserr(g_('cannot write %s'), $applied); print { $applied_fh } "$patch\n"; close($applied_fh) or syserr(g_('cannot close %s'), $applied); } elsif (-e $patch) { unlink($patch) or syserr(g_('cannot remove %s'), $patch); } return $patch; } sub _is_bad_patch_name { my ($dir, $patch_name) = @_; return 1 if not defined($patch_name); return 1 if not length($patch_name); my $patch = File::Spec->catfile($dir, 'debian', 'patches', $patch_name); if (-e $patch) { warning(g_('cannot register changes in %s, this patch already exists'), $patch); return 1; } return 0; } sub do_commit { my ($self, $dir) = @_; my ($patch_name, $tmpdiff) = @{$self->{options}{ARGV}}; $self->prepare_build($dir); # Try to fix up a broken relative filename for the patch if ($tmpdiff and not -e $tmpdiff) { $tmpdiff = File::Spec->catfile($dir, $tmpdiff) unless File::Spec->file_name_is_absolute($tmpdiff); error(g_("patch file '%s' doesn't exist"), $tmpdiff) if not -e $tmpdiff; } my $binaryfiles = Dpkg::Source::BinaryFiles->new($dir); my $handle_binary = sub { my ($self, $old, $new, %opts) = @_; my $fn = File::Spec->abs2rel($new, $dir); $binaryfiles->new_binary_found($fn); }; unless ($tmpdiff) { $tmpdiff = $self->_generate_patch($dir, handle_binary => $handle_binary, usage => 'commit'); $binaryfiles->update_debian_source_include_binaries(); } push_exit_handler(sub { unlink($tmpdiff) }); unless (-s $tmpdiff) { unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff); info(g_('there are no local changes to record')); return; } while (_is_bad_patch_name($dir, $patch_name)) { # Ask the patch name interactively print g_('Enter the desired patch name: '); $patch_name = <STDIN>; if (not defined $patch_name) { error(g_('no patch name given; cannot proceed')); } chomp $patch_name; $patch_name =~ s/\s+/-/g; $patch_name =~ s/\///g; } make_path(File::Spec->catdir($dir, 'debian', 'patches')); my $patch = $self->register_patch($dir, $tmpdiff, $patch_name); my @editors = ('sensible-editor', $ENV{VISUAL}, $ENV{EDITOR}, 'vi'); my $editor = first { find_command($_) } @editors; if (not $editor) { error(g_('cannot find an editor')); } system($editor, $patch); subprocerr($editor) if $?; unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff); pop_exit_handler(); info(g_('local changes have been recorded in a new patch: %s'), $patch); } 1; PK ! ��4: 4: Deps.pmnu �[��� # 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; =encoding utf8 =head1 NAME Dpkg::Deps - parse and manipulate dependencies of Debian packages =head1 DESCRIPTION The Dpkg::Deps module provides classes implementing various types of dependencies. The most important function is deps_parse(), it turns a dependency line in a set of Dpkg::Deps::{Simple,AND,OR,Union} objects depending on the case. =head1 FUNCTIONS All the deps_* functions are exported by default. =over 4 =cut use strict; use warnings; use feature qw(current_sub); our $VERSION = '1.07'; our @EXPORT = qw( deps_concat deps_parse deps_eval_implication deps_iterate deps_compare ); use Carp; use Exporter qw(import); use Dpkg::Version; 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) ($rel_p, $v_p) and ($rel_q, $v_q) express two dependencies as (relation, version). The relation variable can have the following values that are exported by Dpkg::Version: REL_EQ, REL_LT, REL_LE, REL_GT, REL_GT. This functions returns 1 if the "p" dependency implies the "q" dependency. It returns 0 if the "p" dependency implies that "q" is not satisfied. It returns undef when there's no implication. The $v_p and $v_q parameter should be Dpkg::Version objects. =cut sub deps_eval_implication { my ($rel_p, $v_p, $rel_q, $v_q) = @_; # If versions are not valid, we can't decide of any implication return unless defined($v_p) and $v_p->is_valid(); return unless defined($v_q) and $v_q->is_valid(); # q wants an exact version, so p must provide that exact version. p # disproves q if q's version is outside the range enforced by p. if ($rel_q eq REL_EQ) { if ($rel_p eq REL_LT) { return ($v_p <= $v_q) ? 0 : undef; } elsif ($rel_p eq REL_LE) { return ($v_p < $v_q) ? 0 : undef; } elsif ($rel_p eq REL_GT) { return ($v_p >= $v_q) ? 0 : undef; } elsif ($rel_p eq REL_GE) { return ($v_p > $v_q) ? 0 : undef; } elsif ($rel_p eq REL_EQ) { return ($v_p == $v_q); } } # A greater than clause may disprove a less than clause. An equal # cause might as well. Otherwise, if # p's clause is <<, <=, or =, the version must be <= q's to imply q. if ($rel_q eq REL_LE) { if ($rel_p eq REL_GT) { return ($v_p >= $v_q) ? 0 : undef; } elsif ($rel_p eq REL_GE) { return ($v_p > $v_q) ? 0 : undef; } elsif ($rel_p eq REL_EQ) { return ($v_p <= $v_q) ? 1 : 0; } else { # <<, <= return ($v_p <= $v_q) ? 1 : undef; } } # Similar, but << is stronger than <= so p's version must be << q's # version if the p relation is <= or =. if ($rel_q eq REL_LT) { if ($rel_p eq REL_GT or $rel_p eq REL_GE) { return ($v_p >= $v_p) ? 0 : undef; } elsif ($rel_p eq REL_LT) { return ($v_p <= $v_q) ? 1 : undef; } elsif ($rel_p eq REL_EQ) { return ($v_p < $v_q) ? 1 : 0; } else { # <<, <= return ($v_p < $v_q) ? 1 : undef; } } # Same logic as above, only inverted. if ($rel_q eq REL_GE) { if ($rel_p eq REL_LT) { return ($v_p <= $v_q) ? 0 : undef; } elsif ($rel_p eq REL_LE) { return ($v_p < $v_q) ? 0 : undef; } elsif ($rel_p eq REL_EQ) { return ($v_p >= $v_q) ? 1 : 0; } else { # >>, >= return ($v_p >= $v_q) ? 1 : undef; } } if ($rel_q eq REL_GT) { if ($rel_p eq REL_LT or $rel_p eq REL_LE) { return ($v_p <= $v_q) ? 0 : undef; } elsif ($rel_p eq REL_GT) { return ($v_p >= $v_q) ? 1 : undef; } elsif ($rel_p eq REL_EQ) { return ($v_p > $v_q) ? 1 : 0; } else { return ($v_p > $v_q) ? 1 : undef; } } return; } =item $dep = deps_concat(@dep_list) This function concatenates multiple dependency lines into a single line, joining them with ", " if appropriate, and always returning a valid string. =cut sub deps_concat { my (@dep_list) = @_; return join ', ', grep { defined } @dep_list; } =item $dep = deps_parse($line, %options) This function parses the dependency line and returns an object, either a Dpkg::Deps::AND or a Dpkg::Deps::Union. Various options can alter the behaviour of that function. =over 4 =item use_arch (defaults to 1) Take into account the architecture restriction part of the dependencies. Set to 0 to completely ignore that information. =item host_arch (defaults to the current architecture) Define the host architecture. By default it uses Dpkg::Arch::get_host_arch() to identify the proper architecture. =item build_arch (defaults to the current architecture) Define the build architecture. By default it uses Dpkg::Arch::get_build_arch() to identify the proper architecture. =item reduce_arch (defaults to 0) If set to 1, ignore dependencies that do not concern the current host architecture. This implicitly strips off the architecture restriction list so that the resulting dependencies are directly applicable to the current architecture. =item use_profiles (defaults to 1) Take into account the profile restriction part of the dependencies. Set to 0 to completely ignore that information. =item build_profiles (defaults to no profile) Define the active build profiles. By default no profile is defined. =item reduce_profiles (defaults to 0) If set to 1, ignore dependencies that do not concern the current build profile. This implicitly strips off the profile restriction formula so that the resulting dependencies are directly applicable to the current profiles. =item reduce_restrictions (defaults to 0) If set to 1, ignore dependencies that do not concern the current set of restrictions. This implicitly strips off any architecture restriction list or restriction formula so that the resulting dependencies are directly applicable to the current restriction. This currently implies C<reduce_arch> and C<reduce_profiles>, and overrides them if set. =item union (defaults to 0) 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”. This should be set whenever working with build-deps. =item tests_dep (defaults to 0) If set to 1, allow tests-specific package names in dependencies, that is "@" and "@builddeps@" (since dpkg 1.18.7). This should be set whenever working with dependency fields from F<debian/tests/control>. =back =cut sub deps_parse { my ($dep_line, %options) = @_; # Validate arguments. croak "invalid host_arch $options{host_arch}" if defined $options{host_arch} and not defined debarch_to_debtuple($options{host_arch}); croak "invalid build_arch $options{build_arch}" if defined $options{build_arch} and not defined debarch_to_debtuple($options{build_arch}); $options{use_arch} //= 1; $options{reduce_arch} //= 0; $options{use_profiles} //= 1; $options{reduce_profiles} //= 0; $options{reduce_restrictions} //= 0; $options{union} //= 0; $options{virtual} //= 0; $options{build_dep} //= 0; $options{tests_dep} //= 0; if ($options{reduce_restrictions}) { $options{reduce_arch} = 1; $options{reduce_profiles} = 1; } if ($options{reduce_arch}) { $options{host_arch} //= get_host_arch(); $options{build_arch} //= get_build_arch(); } if ($options{reduce_profiles}) { $options{build_profiles} //= [ get_build_profiles() ]; } # Options for Dpkg::Deps::Simple. my %deps_options = ( host_arch => $options{host_arch}, build_arch => $options{build_arch}, build_dep => $options{build_dep}, tests_dep => $options{tests_dep}, ); # Strip trailing/leading spaces $dep_line =~ s/^\s+//; $dep_line =~ s/\s+$//; my @dep_list; foreach my $dep_and (split(/\s*,\s*/m, $dep_line)) { my @or_list = (); foreach my $dep_or (split(/\s*\|\s*/m, $dep_and)) { my $dep_simple = Dpkg::Deps::Simple->new($dep_or, %deps_options); if (not defined $dep_simple->{package}) { 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}); next if not $dep_simple->arch_is_concerned($options{host_arch}); } $dep_simple->{restrictions} = undef if not $options{use_profiles}; if ($options{reduce_profiles}) { $dep_simple->reduce_profiles($options{build_profiles}); next if not $dep_simple->profile_is_concerned($options{build_profiles}); } push @or_list, $dep_simple; } next if not @or_list; if (scalar @or_list == 1) { push @dep_list, $or_list[0]; } else { my $dep_or = Dpkg::Deps::OR->new(); $dep_or->add($_) foreach (@or_list); push @dep_list, $dep_or; } } my $dep_and; if ($options{union}) { $dep_and = Dpkg::Deps::Union->new(); } else { $dep_and = Dpkg::Deps::AND->new(); } foreach my $dep (@dep_list) { if ($options{union} and not $dep->isa('Dpkg::Deps::Simple')) { warning(g_('an union dependency can only contain simple dependencies')); return; } $dep_and->add($dep); } return $dep_and; } =item $bool = deps_iterate($deps, $callback_func) This function visits all elements of the dependency object, calling the callback function for each element. The callback function is expected to return true when everything is fine, or false if something went wrong, in which case the iteration will stop. Return the same value as the callback function. =cut sub deps_iterate { my ($deps, $callback_func) = @_; my $visitor_func = sub { foreach my $dep (@_) { return unless defined $dep; if ($dep->isa('Dpkg::Deps::Simple')) { return unless $callback_func->($dep); } else { return unless __SUB__->($dep->get_deps()); } } return 1; }; return $visitor_func->($deps); } =item deps_compare($a, $b) Implements a comparison operator between two dependency objects. This function is mainly used to implement the sort() method. =back =cut my %relation_ordering = ( undef => 0, REL_GE() => 1, REL_GT() => 2, REL_EQ() => 3, REL_LT() => 4, REL_LE() => 5, ); sub deps_compare { my ($aref, $bref) = @_; my (@as, @bs); deps_iterate($aref, sub { push @as, @_ }); deps_iterate($bref, sub { push @bs, @_ }); while (1) { my ($a, $b) = (shift @as, shift @bs); my $aundef = not defined $a or $a->is_empty(); my $bundef = not defined $b or $b->is_empty(); return 0 if $aundef and $bundef; return -1 if $aundef; return 1 if $bundef; my $ar = $a->{relation} // 'undef'; my $br = $b->{relation} // 'undef'; my $av = $a->{version} // ''; my $bv = $b->{version} // ''; my $res = (($a->{package} cmp $b->{package}) || ($relation_ordering{$ar} <=> $relation_ordering{$br}) || ($av cmp $bv)); return $res if $res != 0; } } =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 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. 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 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. =head1 CHANGES =head2 Version 1.07 (dpkg 1.20.0) 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) New option: Add tests_dep option to Dpkg::Deps::deps_parse(). =head2 Version 1.05 (dpkg 1.17.14) New function: Dpkg::Deps::deps_iterate(). =head2 Version 1.04 (dpkg 1.17.10) New options: Add use_profiles, build_profiles, reduce_profiles and reduce_restrictions to Dpkg::Deps::deps_parse(). =head2 Version 1.03 (dpkg 1.17.0) New option: Add build_arch option to Dpkg::Deps::deps_parse(). =head2 Version 1.02 (dpkg 1.17.0) New function: Dpkg::Deps::deps_concat() =head2 Version 1.01 (dpkg 1.16.1) <Used to document changes to Dpkg::Deps::* modules before they were split.> =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! ���*�2 �2 Compression/FileHandle.pmnu �[��� # Copyright © 2008-2010 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2012-2014 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::Compression::FileHandle; use strict; use warnings; our $VERSION = '1.01'; use Carp; use Dpkg::Compression; use Dpkg::Compression::Process; use Dpkg::Gettext; use Dpkg::ErrorHandling; use parent qw(IO::File Tie::Handle); # Useful reference to understand some kludges required to # have the class behave like a filehandle # http://blog.woobling.org/2009/10/are-filehandles-objects.html =encoding utf8 =head1 NAME Dpkg::Compression::FileHandle - class dealing transparently with file compression =head1 SYNOPSIS use Dpkg::Compression::FileHandle; my ($fh, @lines); $fh = Dpkg::Compression::FileHandle->new(filename => 'sample.gz'); print $fh "Something\n"; close $fh; $fh = Dpkg::Compression::FileHandle->new(); open($fh, '>', 'sample.bz2'); print $fh "Something\n"; close $fh; $fh = Dpkg::Compression::FileHandle->new(); $fh->open('sample.xz', 'w'); $fh->print("Something\n"); $fh->close(); $fh = Dpkg::Compression::FileHandle->new(filename => 'sample.gz'); @lines = <$fh>; close $fh; $fh = Dpkg::Compression::FileHandle->new(); open($fh, '<', 'sample.bz2'); @lines = <$fh>; close $fh; $fh = Dpkg::Compression::FileHandle->new(); $fh->open('sample.xz', 'r'); @lines = $fh->getlines(); $fh->close(); =head1 DESCRIPTION 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>. If you don't open the file explicitly, it will be auto-opened on the first read or write operation based on the filename set at creation time (or later with the C<set_filename> method). Once a file has been opened, the filehandle must be closed before being able to open another file. =head1 STANDARD FUNCTIONS The standard functions acting on filehandles should accept a Dpkg::Compression::FileHandle object transparently including C<open> (only when using the variant with 3 parameters), C<close>, C<binmode>, C<eof>, C<fileno>, C<getc>, C<print>, C<printf>, C<read>, C<sysread>, C<say>, C<write>, C<syswrite>, C<seek>, C<sysseek>, C<tell>. Note however that C<seek> and C<sysseek> will only work on uncompressed files as compressed files are really pipes to the compressor programs and you can't seek on a pipe. =head1 FileHandle METHODS 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 =over 4 =item $fh = Dpkg::Compression::FileHandle->new(%opts) Creates a new filehandle supporting on-the-fly compression/decompression. Supported options are "filename", "compression", "compression_level" (see respective set_* functions) and "add_comp_ext". If "add_comp_ext" evaluates to true, then the extension corresponding to the selected compression scheme is automatically added to the recorded filename. It's obviously incompatible with automatic detection of the compression method. =cut # Class methods sub new { my ($this, %args) = @_; my $class = ref($this) || $this; my $self = IO::File->new(); # Tying is required to overload the open functions and to auto-open # the file on first read/write operation tie *$self, $class, $self; ## no critic (Miscellanea::ProhibitTies) bless $self, $class; # Initializations *$self->{compression} = 'auto'; *$self->{compressor} = Dpkg::Compression::Process->new(); *$self->{add_comp_ext} = $args{add_compression_extension} || $args{add_comp_ext} || 0; *$self->{allow_sigpipe} = 0; if (exists $args{filename}) { $self->set_filename($args{filename}); } if (exists $args{compression}) { $self->set_compression($args{compression}); } if (exists $args{compression_level}) { $self->set_compression_level($args{compression_level}); } return $self; } =item $fh->ensure_open($mode, %opts) Ensure the file is opened in the requested mode ("r" for read and "w" for write). The options are passed down to the compressor's spawn() call, if one is used. Opens the file with the recorded filename if needed. If the file is already open but not in the requested mode, then it errors out. =cut sub ensure_open { my ($self, $mode, %opts) = @_; if (exists *$self->{mode}) { return if *$self->{mode} eq $mode; croak "ensure_open requested incompatible mode: $mode"; } else { # Sanitize options. delete $opts{from_pipe}; delete $opts{from_file}; delete $opts{to_pipe}; delete $opts{to_file}; if ($mode eq 'w') { $self->_open_for_write(%opts); } elsif ($mode eq 'r') { $self->_open_for_read(%opts); } else { croak "invalid mode in ensure_open: $mode"; } } } ## ## METHODS FOR TIED HANDLE ## sub TIEHANDLE { my ($class, $self) = @_; return $self; } sub WRITE { my ($self, $scalar, $length, $offset) = @_; $self->ensure_open('w'); return *$self->{file}->write($scalar, $length, $offset); } sub READ { my ($self, $scalar, $length, $offset) = @_; $self->ensure_open('r'); return *$self->{file}->read($scalar, $length, $offset); } sub READLINE { my ($self) = shift; $self->ensure_open('r'); return *$self->{file}->getlines() if wantarray; return *$self->{file}->getline(); } sub OPEN { my ($self) = shift; if (scalar(@_) == 2) { my ($mode, $filename) = @_; $self->set_filename($filename); if ($mode eq '>') { $self->_open_for_write(); } elsif ($mode eq '<') { $self->_open_for_read(); } else { croak 'Dpkg::Compression::FileHandle does not support ' . "open() mode $mode"; } } else { croak 'Dpkg::Compression::FileHandle only supports open() ' . 'with 3 parameters'; } return 1; # Always works (otherwise errors out) } sub CLOSE { my ($self) = shift; my $ret = 1; if (defined *$self->{file}) { $ret = *$self->{file}->close(@_) if *$self->{file}->opened(); } else { $ret = 0; } $self->_cleanup(); return $ret; } sub FILENO { my ($self) = shift; return *$self->{file}->fileno(@_) if defined *$self->{file}; return; } sub EOF { # Since perl 5.12, an integer parameter is passed describing how the # function got called, just ignore it. my ($self, $param) = (shift, shift); return *$self->{file}->eof(@_) if defined *$self->{file}; return 1; } sub SEEK { my ($self) = shift; return *$self->{file}->seek(@_) if defined *$self->{file}; return 0; } sub TELL { my ($self) = shift; return *$self->{file}->tell(@_) if defined *$self->{file}; return -1; } sub BINMODE { my ($self) = shift; return *$self->{file}->binmode(@_) if defined *$self->{file}; return; } ## ## NORMAL METHODS ## =item $fh->set_compression($comp) Defines the compression method used. $comp should one of the methods supported by B<Dpkg::Compression> or "none" or "auto". "none" indicates that the file is uncompressed and "auto" indicates that the method must be guessed based on the filename extension used. =cut sub set_compression { my ($self, $method) = @_; if ($method ne 'none' and $method ne 'auto') { *$self->{compressor}->set_compression($method); } *$self->{compression} = $method; } =item $fh->set_compression_level($level) Indicate the desired compression level. It should be a value accepted by the function C<compression_is_valid_level> of B<Dpkg::Compression>. =cut sub set_compression_level { my ($self, $level) = @_; *$self->{compressor}->set_compression_level($level); } =item $fh->set_filename($name, [$add_comp_ext]) Use $name as filename when the file must be opened/created. If $add_comp_ext is passed, it indicates whether the default extension of the compression method must be automatically added to the filename (or not). =cut sub set_filename { my ($self, $filename, $add_comp_ext) = @_; *$self->{filename} = $filename; # Automatically add compression extension to filename if (defined($add_comp_ext)) { *$self->{add_comp_ext} = $add_comp_ext; } my $comp_ext_regex = compression_get_file_extension_regex(); if (*$self->{add_comp_ext} and $filename =~ /\.$comp_ext_regex$/) { warning('filename %s already has an extension of a compressed file ' . 'and add_comp_ext is active', $filename); } } =item $file = $fh->get_filename() Returns the filename that would be used when the filehandle must be opened (both in read and write mode). This function errors out if "add_comp_ext" is enabled while the compression method is set to "auto". The returned filename includes the extension of the compression method if "add_comp_ext" is enabled. =cut sub get_filename { my $self = shift; my $comp = *$self->{compression}; if (*$self->{add_comp_ext}) { if ($comp eq 'auto') { croak 'automatic detection of compression is ' . 'incompatible with add_comp_ext'; } elsif ($comp eq 'none') { return *$self->{filename}; } else { return *$self->{filename} . '.' . compression_get_property($comp, 'file_ext'); } } else { return *$self->{filename}; } } =item $ret = $fh->use_compression() Returns "0" if no compression is used and the compression method used otherwise. If the compression is set to "auto", the value returned depends on the extension of the filename obtained with the B<get_filename> method. =cut sub use_compression { my $self = shift; my $comp = *$self->{compression}; if ($comp eq 'none') { return 0; } elsif ($comp eq 'auto') { $comp = compression_guess_from_filename($self->get_filename()); *$self->{compressor}->set_compression($comp) if $comp; } return $comp; } =item $real_fh = $fh->get_filehandle() Returns the real underlying filehandle. Useful if you want to pass it along in a derived class. =cut sub get_filehandle { my $self = shift; return *$self->{file} if exists *$self->{file}; } ## INTERNAL METHODS sub _open_for_write { my ($self, %opts) = @_; my $filehandle; croak 'cannot reopen an already opened compressed file' if exists *$self->{mode}; if ($self->use_compression()) { *$self->{compressor}->compress(from_pipe => \$filehandle, to_file => $self->get_filename(), %opts); } else { CORE::open($filehandle, '>', $self->get_filename) or syserr(g_('cannot write %s'), $self->get_filename()); } *$self->{mode} = 'w'; *$self->{file} = $filehandle; } sub _open_for_read { my ($self, %opts) = @_; my $filehandle; croak 'cannot reopen an already opened compressed file' if exists *$self->{mode}; if ($self->use_compression()) { *$self->{compressor}->uncompress(to_pipe => \$filehandle, from_file => $self->get_filename(), %opts); *$self->{allow_sigpipe} = 1; } else { CORE::open($filehandle, '<', $self->get_filename) or syserr(g_('cannot read %s'), $self->get_filename()); } *$self->{mode} = 'r'; *$self->{file} = $filehandle; } sub _cleanup { my $self = shift; my $cmdline = *$self->{compressor}{cmdline} // ''; *$self->{compressor}->wait_end_process(nocheck => *$self->{allow_sigpipe}); if (*$self->{allow_sigpipe}) { require POSIX; unless (($? == 0) || (POSIX::WIFSIGNALED($?) && (POSIX::WTERMSIG($?) == POSIX::SIGPIPE()))) { subprocerr($cmdline); } *$self->{allow_sigpipe} = 0; } delete *$self->{mode}; delete *$self->{file}; } =back =head1 DERIVED CLASSES 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. You can store internal data in a hash but you have to use C<*$self->{...}> to access the associated hash like in the example below: sub set_option { my ($self, $value) = @_; *$self->{option} = $value; } =head1 CHANGES =head2 Version 1.01 (dpkg 1.17.11) New argument: $fh->ensure_open() accepts an %opts argument. =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! ^��� Compression/Process.pmnu �[��� # Copyright © 2008-2010 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Compression::Process; use strict; use warnings; our $VERSION = '1.00'; use Carp; use Dpkg::Compression; use Dpkg::ErrorHandling; use Dpkg::Gettext; use Dpkg::IPC; =encoding utf8 =head1 NAME Dpkg::Compression::Process - run compression/decompression processes =head1 DESCRIPTION This module provides an object oriented interface to run and manage compression/decompression processes. =head1 METHODS =over 4 =item $proc = Dpkg::Compression::Process->new(%opts) Create a new instance of the object. Supported options are "compression" and "compression_level" (see corresponding set_* functions). =cut sub new { my ($this, %args) = @_; my $class = ref($this) || $this; my $self = {}; bless $self, $class; $self->set_compression($args{compression} || compression_get_default()); $self->set_compression_level($args{compression_level} || compression_get_default_level()); return $self; } =item $proc->set_compression($comp) Select the compression method to use. It errors out if the method is not supported according to C<compression_is_supported> (of B<Dpkg::Compression>). =cut sub set_compression { my ($self, $method) = @_; error(g_('%s is not a supported compression method'), $method) unless compression_is_supported($method); $self->{compression} = $method; } =item $proc->set_compression_level($level) Select the compression level to use. It errors out if the level is not valid according to C<compression_is_valid_level> (of B<Dpkg::Compression>). =cut sub set_compression_level { my ($self, $level) = @_; error(g_('%s is not a compression level'), $level) unless compression_is_valid_level($level); $self->{compression_level} = $level; } =item @exec = $proc->get_compress_cmdline() =item @exec = $proc->get_uncompress_cmdline() Returns a list ready to be passed to C<exec>, its first element is the program name (either for compression or decompression) and the following elements are parameters for the program. When executed the program acts as a filter between its standard input and its standard output. =cut sub get_compress_cmdline { my $self = shift; my @prog = (@{compression_get_property($self->{compression}, 'comp_prog')}); my $level = '-' . $self->{compression_level}; $level = '--' . $self->{compression_level} if $self->{compression_level} !~ m/^[1-9]$/; push @prog, $level; return @prog; } sub get_uncompress_cmdline { my $self = shift; return (@{compression_get_property($self->{compression}, 'decomp_prog')}); } sub _sanity_check { my ($self, %opts) = @_; # Check for proper cleaning before new start error(g_('Dpkg::Compression::Process can only start one subprocess at a time')) if $self->{pid}; # Check options my $to = my $from = 0; foreach my $thing (qw(file handle string pipe)) { $to++ if $opts{"to_$thing"}; $from++ if $opts{"from_$thing"}; } croak 'exactly one to_* parameter is needed' if $to != 1; croak 'exactly one from_* parameter is needed' if $from != 1; return %opts; } =item $proc->compress(%opts) Starts a compressor program. You must indicate where it will read its uncompressed data from and where it will write its compressed data to. This is accomplished by passing one parameter C<to_*> and one parameter C<from_*> as accepted by B<Dpkg::IPC::spawn>. You must call C<wait_end_process> after having called this method to properly close the sub-process (and verify that it exited without error). =cut sub compress { my ($self, %opts) = @_; $self->_sanity_check(%opts); my @prog = $self->get_compress_cmdline(); $opts{exec} = \@prog; $self->{cmdline} = "@prog"; $self->{pid} = spawn(%opts); delete $self->{pid} if $opts{to_string}; # wait_child already done } =item $proc->uncompress(%opts) Starts a decompressor program. You must indicate where it will read its compressed data from and where it will write its uncompressed data to. This is accomplished by passing one parameter C<to_*> and one parameter C<from_*> as accepted by B<Dpkg::IPC::spawn>. You must call C<wait_end_process> after having called this method to properly close the sub-process (and verify that it exited without error). =cut sub uncompress { my ($self, %opts) = @_; $self->_sanity_check(%opts); my @prog = $self->get_uncompress_cmdline(); $opts{exec} = \@prog; $self->{cmdline} = "@prog"; $self->{pid} = spawn(%opts); delete $self->{pid} if $opts{to_string}; # wait_child already done } =item $proc->wait_end_process(%opts) Call B<Dpkg::IPC::wait_child> to wait until the sub-process has exited and verify its return code. Any given option will be forwarded to the C<wait_child> function. Most notably you can use the "nocheck" option to verify the return code yourself instead of letting C<wait_child> do it for you. =cut sub wait_end_process { my ($self, %opts) = @_; $opts{cmdline} //= $self->{cmdline}; wait_child($self->{pid}, %opts) if $self->{pid}; delete $self->{pid}; delete $self->{cmdline}; } =back =head1 CHANGES =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! Ϋtӎ � Build/Info.pmnu �[��� # Copyright © 2016 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::Build::Info; use strict; use warnings; our $VERSION = '1.01'; our @EXPORT_OK = qw( get_build_env_whitelist get_build_env_allowed ); use Exporter qw(import); =encoding utf8 =head1 NAME Dpkg::Build::Info - handle build information =head1 DESCRIPTION The Dpkg::Build::Info module provides functions to handle the build information. =head1 FUNCTIONS =over 4 =item @envvars = get_build_env_allowed() Get an array with the allowed list of environment variables that can affect the build, but are still not privacy revealing. =cut my @env_allowed = ( # Toolchain. qw(CC CPP CXX OBJC OBJCXX PC FC M2C AS LD AR RANLIB MAKE AWK LEX YACC), # Toolchain flags. qw(ASFLAGS CFLAGS CPPFLAGS CXXFLAGS OBJCFLAGS OBJCXXFLAGS GCJFLAGS DFLAGS FFLAGS LDFLAGS ARFLAGS MAKEFLAGS), # Dynamic linker, see ld(1). qw(LD_LIBRARY_PATH), # Locale, see locale(1). qw(LANG LC_ALL LC_CTYPE LC_NUMERIC LC_TIME LC_COLLATE LC_MONETARY LC_MESSAGES LC_PAPER LC_NAME LC_ADDRESS LC_TELEPHONE LC_MEASUREMENT LC_IDENTIFICATION), # Build flags, see dpkg-buildpackage(1). qw(DEB_BUILD_OPTIONS DEB_BUILD_PROFILES), # DEB_flag_{SET,STRIP,APPEND,PREPEND} will be recorded after being merged # with system config and user config. # See deb-vendor(1). qw(DEB_VENDOR), # See dpkg(1). qw(DPKG_ROOT DPKG_ADMINDIR), # See dpkg-architecture(1). qw(DPKG_DATADIR), # See Dpkg::Vendor(3). qw(DPKG_ORIGINS_DIR), # See dpkg-gensymbols(1). qw(DPKG_GENSYMBOLS_CHECK_LEVEL), # See <https://reproducible-builds.org/specs/source-date-epoch>. qw(SOURCE_DATE_EPOCH), ); sub get_build_env_allowed { return @env_allowed; } =item @envvars = get_build_env_whitelist() This is a deprecated alias for get_build_env_allowed(). =cut sub get_build_env_whitelist { warnings::warnif('deprecated', 'Dpkg::Build::Info::get_build_env_whitelist() is deprecated, ' . 'use get_build_env_allowed() instead'); return get_build_env_allowed(); } =back =head1 CHANGES =head2 Version 1.01 (dpkg 1.20.1) New function: get_build_env_allowed(). Deprecated function: get_build_env_whitelist(). =head2 Version 1.00 (dpkg 1.18.14) Mark the module as public. =cut 1; PK ! ,� � Build/Env.pmnu �[��� # Copyright © 2012 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::Build::Env; use strict; use warnings; our $VERSION = '0.01'; my %env_modified = (); my %env_accessed = (); =encoding utf8 =head1 NAME Dpkg::Build::Env - track build environment =head1 DESCRIPTION The Dpkg::Build::Env module is used by dpkg-buildflags to track the build environment variables being used and modified. =head1 FUNCTIONS =over 4 =item set($varname, $value) Update the build environment variable $varname with value $value. Record it as being accessed and modified. =cut sub set { my ($varname, $value) = @_; $env_modified{$varname} = 1; $env_accessed{$varname} = 1; $ENV{$varname} = $value; } =item get($varname) Get the build environment variable $varname value. Record it as being accessed. =cut sub get { my $varname = shift; $env_accessed{$varname} = 1; return $ENV{$varname}; } =item has($varname) Return a boolean indicating whether the environment variable exists. Record it as being accessed. =cut sub has { my $varname = shift; $env_accessed{$varname} = 1; return exists $ENV{$varname}; } =item @list = list_accessed() Returns a list of all environment variables that have been accessed. =cut sub list_accessed { my @list = sort keys %env_accessed; return @list; } =item @list = list_modified() Returns a list of all environment variables that have been modified. =cut sub list_modified { my @list = sort keys %env_modified; return @list; } =back =head1 CHANGES =head2 Version 0.xx This is a private module. =cut 1; PK ! rZ�_� � Build/Types.pmnu �[��� # Copyright © 2007 Frank Lichtenheld <djpig@debian.org> # Copyright © 2010, 2013-2016 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::Build::Types; use strict; use warnings; our $VERSION = '0.02'; our @EXPORT = qw( BUILD_DEFAULT BUILD_SOURCE BUILD_ARCH_DEP BUILD_ARCH_INDEP BUILD_BINARY BUILD_FULL build_has_any build_has_all build_has_none build_is set_build_type set_build_type_from_options set_build_type_from_targets get_build_options_from_type ); use Exporter qw(import); use Dpkg::Gettext; use Dpkg::ErrorHandling; =encoding utf8 =head1 NAME Dpkg::Build::Types - track build types =head1 DESCRIPTION The Dpkg::Build::Types module is used by various tools to track and decide what artifacts need to be built. The build types are bit constants that are exported by default. Multiple types can be ORed. =head1 CONSTANTS =over 4 =item BUILD_DEFAULT This build is the default. =item BUILD_SOURCE This build includes source artifacts. =item BUILD_ARCH_DEP This build includes architecture dependent binary artifacts. =item BUILD_ARCH_INDEP This build includes architecture independent binary artifacts. =item BUILD_BINARY This build includes binary artifacts. =item BUILD_FULL This build includes source and binary artifacts. =cut # Simple types. use constant { BUILD_DEFAULT => 1, BUILD_SOURCE => 2, BUILD_ARCH_DEP => 4, BUILD_ARCH_INDEP => 8, }; # Composed types. use constant BUILD_BINARY => BUILD_ARCH_DEP | BUILD_ARCH_INDEP; use constant BUILD_FULL => BUILD_BINARY | BUILD_SOURCE; my $current_type = BUILD_FULL | BUILD_DEFAULT; my $current_option = undef; my @build_types = qw(full source binary any all); my %build_types = ( full => BUILD_FULL, source => BUILD_SOURCE, binary => BUILD_BINARY, 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 =head1 FUNCTIONS =over 4 =item build_has_any($bits) Return a boolean indicating whether the current build type has any of the specified $bits. =cut sub build_has_any { my ($bits) = @_; return $current_type & $bits; } =item build_has_all($bits) Return a boolean indicating whether the current build type has all the specified $bits. =cut sub build_has_all { my ($bits) = @_; return ($current_type & $bits) == $bits; } =item build_has_none($bits) Return a boolean indicating whether the current build type has none of the specified $bits. =cut sub build_has_none { my ($bits) = @_; return !($current_type & $bits); } =item build_is($bits) Return a boolean indicating whether the current build type is the specified set of $bits. =cut sub build_is { my ($bits) = @_; return $current_type == $bits; } =item set_build_type($build_type, $build_option, %opts) Set the current build type to $build_type, which was specified via the $build_option command-line option. 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 { my ($build_type, $build_option, %opts) = @_; usageerr(g_('cannot combine %s and %s'), $current_option, $build_option) if not $opts{nocheck} and build_has_none(BUILD_DEFAULT) and $current_type != $build_type; $current_type = $build_type; $current_option = $build_option; } =item set_build_type_from_options($build_types, $build_option, %opts) 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". =cut sub set_build_type_from_options { my ($build_parts, $build_option, %opts) = @_; my $build_type = 0; foreach my $type (split /,/, $build_parts) { usageerr(g_('unknown build type %s'), $type) unless exists $build_types{$type}; $build_type |= $build_types{$type}; } 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. =cut sub get_build_options_from_type { my $local_type = $current_type; my @parts; foreach my $type (@build_types) { my $part_bits = $build_types{$type}; if (($local_type & $part_bits) == $part_bits) { push @parts, $type; $local_type &= ~$part_bits; } } return join ',', @parts; } =back =head1 CHANGES =head2 Version 0.xx This is a private module. =cut 1; PK ! ԉ�&� � Interface/Storable.pmnu �[��� # Copyright © 2010 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Interface::Storable; use strict; use warnings; our $VERSION = '1.01'; use Carp; use Dpkg::Gettext; use Dpkg::ErrorHandling; use overload '""' => \&_stringify, 'fallback' => 1; =encoding utf8 =head1 NAME 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 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 class that wish to inherit from Dpkg::Interface::Storable so that the methods provided can work. =over 4 =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]) This method returns a string representation of the object in $string and it writes the same string to $fh (if it's defined). =back =head1 PROVIDED METHODS =over 4 =item $obj->load($filename, %opts) Initialize the object with the data stored in the file. The file can be compressed, it will be decompressed on the fly by using a Dpkg::Compression::FileHandle object. If $opts{compression} is false the decompression support will be disabled. If $filename is "-", then the standard input is read (no compression is allowed in that case). =cut sub load { my ($self, $file, %opts) = @_; $opts{compression} //= 1; unless ($self->can('parse')) { croak ref($self) . ' cannot be loaded, it lacks the parse method'; } my ($desc, $fh) = ($file, undef); if ($file eq '-') { $fh = \*STDIN; $desc = g_('<standard input>'); } else { if ($opts{compression}) { require Dpkg::Compression::FileHandle; $fh = Dpkg::Compression::FileHandle->new(); } open($fh, '<', $file) or syserr(g_('cannot read %s'), $file); } my $res = $self->parse($fh, $desc, %opts); if ($file ne '-') { close($fh) or syserr(g_('cannot close %s'), $file); } return $res; } =item $obj->save($filename, %opts) Store the object in the file. If the filename ends with a known compression extension, it will be compressed on the fly by using a Dpkg::Compression::FileHandle object. If $opts{compression} is false the compression support will be disabled. If $filename is "-", then the standard output is used (data are written uncompressed in that case). =cut sub save { my ($self, $file, %opts) = @_; $opts{compression} //= 1; unless ($self->can('output')) { croak ref($self) . ' cannot be saved, it lacks the output method'; } my $fh; if ($file eq '-') { $fh = \*STDOUT; } else { if ($opts{compression}) { require Dpkg::Compression::FileHandle; $fh = Dpkg::Compression::FileHandle->new(); } open($fh, '>', $file) or syserr(g_('cannot write %s'), $file); } $self->output($fh, %opts); if ($file ne '-') { close($fh) or syserr(g_('cannot close %s'), $file); } } =item "$obj" Return a string representation of the object. =cut sub _stringify { my $self = shift; unless ($self->can('output')) { croak ref($self) . ' cannot be stringified, it lacks the output method'; } return $self->output(); } =back =head1 CHANGES =head2 Version 1.01 (dpkg 1.19.0) New options: The $obj->load() and $obj->save() methods support a new compression option. =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! k�� � Dist/Files.pmnu �[��� # Copyright © 2014-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::Dist::Files; use strict; use warnings; our $VERSION = '0.01'; use IO::Dir; use Dpkg::Gettext; use Dpkg::ErrorHandling; use parent qw(Dpkg::Interface::Storable); sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; my $self = { options => [], files => {}, }; foreach my $opt (keys %opts) { $self->{$opt} = $opts{$opt}; } bless $self, $class; return $self; } sub reset { my $self = shift; $self->{files} = {}; } sub parse_filename { my ($self, $fn) = @_; my $file; if ($fn =~ m/^(([-+:.0-9a-z]+)_([^_]+)_([-\w]+)\.([a-z0-9.]+))$/) { # Artifact using the common <name>_<version>_<arch>.<type> pattern. $file->{filename} = $1; $file->{package} = $2; $file->{version} = $3; $file->{arch} = $4; $file->{package_type} = $5; } elsif ($fn =~ m/^([-+:.,_0-9a-zA-Z~]+)$/) { # Artifact with no common pattern, usually called byhand or raw, as # they might require manual processing on the server side, or custom # actions per file type. $file->{filename} = $1; } else { $file = undef; } return $file; } sub parse { my ($self, $fh, $desc) = @_; my $count = 0; local $_; binmode $fh; while (<$fh>) { chomp; my $file; if (m/^(\S+) (\S+) (\S+)((?:\s+[0-9a-z-]+=\S+)*)$/) { $file = $self->parse_filename($1); error(g_('badly formed file 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'), $.); } if (defined $self->{files}->{$file->{filename}}) { warning(g_('duplicate files list entry for file %s (line %d)'), $file->{filename}, $.); } else { $count++; $self->{files}->{$file->{filename}} = $file; } } return $count; } sub load_dir { my ($self, $dir) = @_; my $count = 0; my $dh = IO::Dir->new($dir) or syserr(g_('cannot open directory %s'), $dir); while (defined(my $file = $dh->read)) { my $pathname = "$dir/$file"; next unless -f $pathname; $count += $self->load($pathname); } return $count; } sub get_files { my $self = shift; return map { $self->{files}->{$_} } sort keys %{$self->{files}}; } sub get_file { my ($self, $filename) = @_; return $self->{files}->{$filename}; } sub add_file { 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; return $file; } sub del_file { my ($self, $filename) = @_; delete $self->{files}->{$filename}; } sub filter { my ($self, %opts) = @_; my $remove = $opts{remove} // sub { 0 }; my $keep = $opts{keep} // sub { 1 }; foreach my $filename (keys %{$self->{files}}) { my $file = $self->{files}->{$filename}; if (not $keep->($file) or $remove->($file)) { delete $self->{files}->{$filename}; } } } sub output { my ($self, $fh) = @_; my $str = ''; binmode $fh if defined $fh; foreach my $filename (sort keys %{$self->{files}}) { my $file = $self->{files}->{$filename}; 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; } return $str; } 1; PK ! ����Z Z Vendor.pmnu �[��� # Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Vendor; use strict; use warnings; use feature qw(state); our $VERSION = '1.01'; our @EXPORT_OK = qw( get_current_vendor get_vendor_info get_vendor_file get_vendor_dir get_vendor_object run_vendor_hook ); use Exporter qw(import); use Dpkg (); use Dpkg::ErrorHandling; use Dpkg::Gettext; use Dpkg::Build::Env; use Dpkg::Control::HashCore; my $origins = "$Dpkg::CONFDIR/origins"; $origins = $ENV{DPKG_ORIGINS_DIR} if $ENV{DPKG_ORIGINS_DIR}; =encoding utf8 =head1 NAME Dpkg::Vendor - get access to some vendor specific information =head1 DESCRIPTION The files in $Dpkg::CONFDIR/origins/ can provide information about various vendors who are providing Debian packages. Currently those files look like this: Vendor: Debian Vendor-URL: https://www.debian.org/ Bugs: debbugs://bugs.debian.org If the vendor derives from another vendor, the file should document the relationship by listing the base distribution in the Parent field: Parent: Debian The file should be named according to the vendor name. The usual convention is to name the vendor file using the vendor name in all lowercase, but some variation is permitted. Namely, spaces are mapped to dashes ('-'), and the file can have the same casing as the Vendor field, or it can be capitalized. =head1 FUNCTIONS =over 4 =item $dir = get_vendor_dir() Returns the current dpkg origins directory name, where the vendor files are stored. =cut sub get_vendor_dir { return $origins; } =item $fields = get_vendor_info($name) Returns a Dpkg::Control object with the information parsed from the corresponding vendor file in $Dpkg::CONFDIR/origins/. If $name is omitted, it will use $Dpkg::CONFDIR/origins/default which is supposed to be a symlink to the vendor of the currently installed operating system. Returns undef if there's no file for the given vendor. =cut sub get_vendor_info(;$) { my $vendor = shift || 'default'; state %VENDOR_CACHE; return $VENDOR_CACHE{$vendor} if exists $VENDOR_CACHE{$vendor}; my $file = get_vendor_file($vendor); return unless $file; my $fields = Dpkg::Control::HashCore->new(); $fields->load($file, compression => 0) or error(g_('%s is empty'), $file); $VENDOR_CACHE{$vendor} = $fields; return $fields; } =item $name = get_vendor_file($name) Check if there's a file for the given vendor and returns its name. =cut sub get_vendor_file(;$) { my $vendor = shift || 'default'; my $file; my @tries = ($vendor, lc($vendor), ucfirst($vendor), ucfirst(lc($vendor))); if ($vendor =~ s/\s+/-/) { push @tries, $vendor, lc($vendor), ucfirst($vendor), ucfirst(lc($vendor)); } foreach my $name (@tries) { $file = "$origins/$name" if -e "$origins/$name"; } return $file; } =item $name = get_current_vendor() Returns the name of the current vendor. If DEB_VENDOR is set, it uses that first, otherwise it falls back to parsing $Dpkg::CONFDIR/origins/default. If that file doesn't exist, it returns undef. =cut sub get_current_vendor() { my $f; if (Dpkg::Build::Env::has('DEB_VENDOR')) { $f = get_vendor_info(Dpkg::Build::Env::get('DEB_VENDOR')); return $f->{'Vendor'} if defined $f; } $f = get_vendor_info(); return $f->{'Vendor'} if defined $f; return; } =item $object = get_vendor_object($name) Return the Dpkg::Vendor::* object of the corresponding vendor. If $name is omitted, return the object of the current vendor. If no vendor can be identified, then return the Dpkg::Vendor::Default object. =cut sub get_vendor_object { my $vendor = shift || get_current_vendor() || 'Default'; state %OBJECT_CACHE; return $OBJECT_CACHE{$vendor} if exists $OBJECT_CACHE{$vendor}; my ($obj, @names); push @names, $vendor, lc($vendor), ucfirst($vendor), ucfirst(lc($vendor)); foreach my $name (@names) { eval qq{ pop \@INC if \$INC[-1] eq '.'; require Dpkg::Vendor::$name; \$obj = Dpkg::Vendor::$name->new(); }; unless ($@) { $OBJECT_CACHE{$vendor} = $obj; return $obj; } } my $info = get_vendor_info($vendor); if (defined $info and defined $info->{'Parent'}) { return get_vendor_object($info->{'Parent'}); } else { return get_vendor_object('Default'); } } =item run_vendor_hook($hookid, @params) Run a hook implemented by the current vendor object. =cut sub run_vendor_hook { my $vendor_obj = get_vendor_object(); $vendor_obj->run_hook(@_); } =back =head1 CHANGES =head2 Version 1.01 (dpkg 1.17.0) New function: get_vendor_dir(). =head2 Version 1.00 (dpkg 1.16.1) Mark the module as public. =head1 SEE ALSO deb-origin(5). =cut 1; PK ! ��jf" f" Path.pmnu �[��� # Copyright © 2007-2011 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2011 Linaro Limited # # 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::Path; use strict; use warnings; our $VERSION = '1.05'; our @EXPORT_OK = qw( canonpath resolve_symlink check_files_are_the_same check_directory_traversal find_command find_build_file get_control_path get_pkg_root_dir guess_pkg_root_dir relative_to_pkg_root ); use Exporter qw(import); use Errno qw(ENOENT); use File::Spec; use File::Find; use Cwd qw(realpath); use Dpkg::ErrorHandling; use Dpkg::Gettext; use Dpkg::Arch qw(get_host_arch debarch_to_debtuple); use Dpkg::IPC; =encoding utf8 =head1 NAME Dpkg::Path - some common path handling functions =head1 DESCRIPTION It provides some functions to handle various path. =head1 FUNCTIONS =over 8 =item get_pkg_root_dir($file) This function will scan upwards the hierarchy of directory to find out the directory which contains the "DEBIAN" sub-directory and it will return its path. This directory is the root directory of a package being built. If no DEBIAN subdirectory is found, it will return undef. =cut sub get_pkg_root_dir($) { my $file = shift; $file =~ s{/+$}{}; $file =~ s{/+[^/]+$}{} if not -d $file; while ($file) { return $file if -d "$file/DEBIAN"; last if $file !~ m{/}; $file =~ s{/+[^/]+$}{}; } return; } =item relative_to_pkg_root($file) Returns the filename relative to get_pkg_root_dir($file). =cut sub relative_to_pkg_root($) { my $file = shift; my $pkg_root = get_pkg_root_dir($file); if (defined $pkg_root) { $pkg_root .= '/'; return $file if ($file =~ s/^\Q$pkg_root\E//); } return; } =item guess_pkg_root_dir($file) This function tries to guess the root directory of the package build tree. It will first use get_pkg_root_dir(), but it will fallback to a more imprecise check: namely it will use the parent directory that is a sub-directory of the debian directory. It can still return undef if a file outside of the debian sub-directory is provided. =cut sub guess_pkg_root_dir($) { my $file = shift; my $root = get_pkg_root_dir($file); return $root if defined $root; $file =~ s{/+$}{}; $file =~ s{/+[^/]+$}{} if not -d $file; my $parent = $file; while ($file) { $parent =~ s{/+[^/]+$}{}; last if not -d $parent; return $file if check_files_are_the_same('debian', $parent); $file = $parent; last if $file !~ m{/}; } return; } =item check_files_are_the_same($file1, $file2, $resolve_symlink) This function verifies that both files are the same by checking that the device numbers and the inode numbers returned by stat()/lstat() are the same. If $resolve_symlink is true then stat() is used, otherwise lstat() is used. =cut sub check_files_are_the_same($$;$) { my ($file1, $file2, $resolve_symlink) = @_; return 1 if $file1 eq $file2; return 0 if ((! -e $file1) || (! -e $file2)); my (@stat1, @stat2); if ($resolve_symlink) { @stat1 = stat($file1); @stat2 = stat($file2); } else { @stat1 = lstat($file1); @stat2 = lstat($file2); } my $result = ($stat1[0] == $stat2[0]) && ($stat1[1] == $stat2[1]); return $result; } =item canonpath($file) This function returns a cleaned path. It simplifies double //, and remove /./ and /../ intelligently. For /../ it simplifies the path only if the previous element is not a symlink. Thus it should only be used on real filenames. =cut sub canonpath($) { my $path = shift; $path = File::Spec->canonpath($path); my ($v, $dirs, $file) = File::Spec->splitpath($path); my @dirs = File::Spec->splitdir($dirs); my @new; foreach my $d (@dirs) { if ($d eq '..') { if (scalar(@new) > 0 and $new[-1] ne '..') { next if $new[-1] eq ''; # Root directory has no parent my $parent = File::Spec->catpath($v, File::Spec->catdir(@new), ''); if (not -l $parent) { pop @new; } else { push @new, $d; } } else { push @new, $d; } } else { push @new, $d; } } return File::Spec->catpath($v, File::Spec->catdir(@new), $file); } =item $newpath = resolve_symlink($symlink) Return the filename of the file pointed by the symlink. The new name is canonicalized by canonpath(). =cut sub resolve_symlink($) { my $symlink = shift; my $content = readlink($symlink); return unless defined $content; if (File::Spec->file_name_is_absolute($content)) { return canonpath($content); } else { my ($link_v, $link_d, $link_f) = File::Spec->splitpath($symlink); my ($cont_v, $cont_d, $cont_f) = File::Spec->splitpath($content); my $new = File::Spec->catpath($link_v, $link_d . '/' . $cont_d, $cont_f); return canonpath($new); } } =item check_directory_traversal($basedir, $dir) This function verifies that the directory $dir does not contain any symlink that goes beyond $basedir (which should be either equal or a parent of $dir). =cut sub check_directory_traversal { my ($basedir, $dir) = @_; my $canon_basedir = realpath($basedir); my $check_symlinks = sub { my $canon_pathname = realpath($_); if (not defined $canon_pathname) { return if $! == ENOENT; syserr(g_("pathname '%s' cannot be canonicalized"), $_); } return if $canon_pathname eq '/dev/null'; return if $canon_pathname eq $canon_basedir; return if $canon_pathname =~ m{^\Q$canon_basedir/\E}; error(g_("pathname '%s' points outside source root (to '%s')"), $_, $canon_pathname); }; find({ wanted => $check_symlinks, no_chdir => 1, follow => 1, follow_skip => 2, }, $dir); return; } =item $cmdpath = find_command($command) Return the path of the command if defined and available on an absolute or relative path or on the $PATH, undef otherwise. =cut sub find_command($) { my $cmd = shift; return if not $cmd; if ($cmd =~ m{/}) { return "$cmd" if -x "$cmd"; } else { foreach my $dir (split(/:/, $ENV{PATH})) { return "$dir/$cmd" if -x "$dir/$cmd"; } } return; } =item $control_file = get_control_path($pkg, $filetype) Return the path of the control file of type $filetype for the given package. =item @control_files = get_control_path($pkg) Return the path of all available control files for the given package. =cut sub get_control_path($;$) { my ($pkg, $filetype) = @_; my $control_file; my @exec = ('dpkg-query', '--control-path', $pkg); push @exec, $filetype if defined $filetype; spawn(exec => \@exec, wait_child => 1, to_string => \$control_file); chomp($control_file); if (defined $filetype) { return if $control_file eq ''; return $control_file; } return () if $control_file eq ''; return split(/\n/, $control_file); } =item $file = find_build_file($basename) Selects the right variant of the given file: the arch-specific variant ("$basename.$arch") has priority over the OS-specific variant ("$basename.$os") which has priority over the default variant ("$basename"). If none of the files exists, then it returns undef. =item @files = find_build_file($basename) Return the available variants of the given file. Returns an empty list if none of the files exists. =cut sub find_build_file($) { my $base = shift; my $host_arch = get_host_arch(); my ($abi, $libc, $host_os, $cpu) = debarch_to_debtuple($host_arch); my @files; foreach my $f ("$base.$host_arch", "$base.$host_os", "$base") { push @files, $f if -f $f; } return @files if wantarray; return $files[0] if scalar @files; return; } =back =head1 CHANGES =head2 Version 1.05 (dpkg 1.20.4) New function: check_directory_traversal(). =head2 Version 1.04 (dpkg 1.17.11) Update semantics: find_command() now handles an empty or undef argument. =head2 Version 1.03 (dpkg 1.16.1) New function: find_build_file() =head2 Version 1.02 (dpkg 1.16.0) New function: get_control_path() =head2 Version 1.01 (dpkg 1.15.8) New function: find_command() =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! 5�� � Control.pmnu �[��� # Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Control; use strict; use warnings; our $VERSION = '1.03'; our @EXPORT = qw( CTRL_UNKNOWN CTRL_INFO_SRC CTRL_INFO_PKG CTRL_INDEX_SRC CTRL_INDEX_PKG CTRL_REPO_RELEASE CTRL_PKG_SRC CTRL_PKG_DEB CTRL_FILE_BUILDINFO CTRL_FILE_CHANGES CTRL_FILE_VENDOR CTRL_FILE_STATUS CTRL_CHANGELOG CTRL_COPYRIGHT_HEADER CTRL_COPYRIGHT_FILES CTRL_COPYRIGHT_LICENSE CTRL_TESTS ); use Exporter qw(import); use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Control::Types; use Dpkg::Control::Hash; use Dpkg::Control::Fields; use parent qw(Dpkg::Control::Hash); =encoding utf8 =head1 NAME Dpkg::Control - parse and manipulate official control-like information =head1 DESCRIPTION The Dpkg::Control object is a smart version of Dpkg::Control::Hash. It associates a type to the control information. That type can be used to know what fields are allowed and in what order they must be output. The types are constants that are exported by default. Here's the full list: =over 4 =item CTRL_UNKNOWN This type is the default type, it indicates that the type of control information is not yet known. =item CTRL_INFO_SRC Corresponds to the first block of information in a F<debian/control> file in a Debian source package. =item CTRL_INFO_PKG Corresponds to subsequent blocks of information in a F<debian/control> file in a Debian source package. =item CTRL_REPO_RELEASE Corresponds to a F<Release> file in a repository. =item CTRL_INDEX_SRC Corresponds to an entry in a F<Sources> file of a source package repository. =item CTRL_INDEX_PKG Corresponds to an entry in a F<Packages> file of a binary package repository. =item CTRL_PKG_SRC Corresponds to a .dsc file of a Debian source package. =item CTRL_PKG_DEB Corresponds to the F<control> file generated by dpkg-gencontrol (F<DEBIAN/control>) and to the same file inside .deb packages. =item CTRL_FILE_BUILDINFO Corresponds to a .buildinfo file. =item CTRL_FILE_CHANGES Corresponds to a .changes file. =item CTRL_FILE_VENDOR Corresponds to a vendor file in $Dpkg::CONFDIR/origins/. =item CTRL_FILE_STATUS Corresponds to an entry in dpkg's F<status> file ($Dpkg::ADMINDIR/status). =item CTRL_CHANGELOG Corresponds to the output of dpkg-parsechangelog. =item CTRL_COPYRIGHT_HEADER Corresponds to the header control block in a F<debian/copyright> file in machine readable format. =item CTRL_COPYRIGHT_FILES Corresponds to a files control block in a F<debian/copyright> file in machine readable format. =item CTRL_COPYRIGHT_LICENSE Corresponds to a license control block in a F<debian/copyright> file in machine readable format. =item CTRL_TESTS Corresponds to a package tests control file in F<debian/tests/control>. =back =head1 METHODS All the methods of Dpkg::Control::Hash are available. Those listed below are either new or overridden with a different behaviour. =over 4 =item $c = Dpkg::Control->new(%opts) If the "type" option is given, it's used to setup default values for other options. See set_options() for more details. =cut sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; my $self = Dpkg::Control::Hash->new(); bless $self, $class; $self->set_options(%opts); return $self; } =item $c->set_options(%opts) Changes the value of one or more options. If the "type" option is changed, it is used first to define default values for others options. The option "allow_pgp" is set to 1 for CTRL_PKG_SRC, CTRL_FILE_CHANGES and CTRL_REPO_RELEASE and to 0 otherwise. The option "drop_empty" is set to 0 for CTRL_INFO_PKG and CTRL_INFO_SRC and to 1 otherwise. The option "name" is set to a textual description of the type of control information. The output order is also set to match the ordered list returned by Dpkg::Control::Fields::field_ordered_list($type). =cut sub set_options { my ($self, %opts) = @_; if (exists $opts{type}) { my $t = $opts{type}; $$self->{allow_pgp} = ($t & (CTRL_PKG_SRC | CTRL_FILE_CHANGES | CTRL_REPO_RELEASE)) ? 1 : 0; $$self->{drop_empty} = ($t & (CTRL_INFO_PKG | CTRL_INFO_SRC)) ? 0 : 1; if ($t == CTRL_INFO_SRC) { $$self->{name} = g_('general section of control info file'); } elsif ($t == CTRL_INFO_PKG) { $$self->{name} = g_("package's section of control info file"); } elsif ($t == CTRL_CHANGELOG) { $$self->{name} = g_('parsed version of changelog'); } elsif ($t == CTRL_COPYRIGHT_HEADER) { $$self->{name} = g_('header stanza of copyright file'); } elsif ($t == CTRL_COPYRIGHT_FILES) { $$self->{name} = g_('files stanza of copyright file'); } elsif ($t == CTRL_COPYRIGHT_HEADER) { $$self->{name} = g_('license stanza of copyright file'); } elsif ($t == CTRL_TESTS) { $$self->{name} = g_("package's tests control file"); } elsif ($t == CTRL_REPO_RELEASE) { $$self->{name} = sprintf(g_("repository's %s file"), 'Release'); } elsif ($t == CTRL_INDEX_SRC) { $$self->{name} = sprintf(g_("entry in repository's %s file"), 'Sources'); } elsif ($t == CTRL_INDEX_PKG) { $$self->{name} = sprintf(g_("entry in repository's %s file"), 'Packages'); } elsif ($t == CTRL_PKG_SRC) { $$self->{name} = sprintf(g_('%s file'), '.dsc'); } elsif ($t == CTRL_PKG_DEB) { $$self->{name} = g_('control info of a .deb package'); } elsif ($t == CTRL_FILE_BUILDINFO) { $$self->{name} = g_('build information file'); } elsif ($t == CTRL_FILE_CHANGES) { $$self->{name} = sprintf(g_('%s file'), '.changes'); } elsif ($t == CTRL_FILE_VENDOR) { $$self->{name} = g_('vendor file'); } elsif ($t == CTRL_FILE_STATUS) { $$self->{name} = g_("entry in dpkg's status file"); } $self->set_output_order(field_ordered_list($opts{type})); } # Options set by the user override default values $$self->{$_} = $opts{$_} foreach keys %opts; } =item $c->get_type() Returns the type of control information stored. See the type parameter set during new(). =cut sub get_type { my $self = shift; return $$self->{type}; } =back =head1 CHANGES =head2 Version 1.03 (dpkg 1.18.11) New type: CTRL_FILE_BUILDINFO. =head2 Version 1.02 (dpkg 1.18.8) New type: CTRL_TESTS. =head2 Version 1.01 (dpkg 1.18.5) New types: CTRL_REPO_RELEASE, CTRL_COPYRIGHT_HEADER, CTRL_COPYRIGHT_FILES, CTRL_COPYRIGHT_LICENSE. =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! b�;q� � Compression.pmnu �[��� # Copyright © 2010 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2010-2013 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::Compression; use strict; use warnings; our $VERSION = '2.00'; our @EXPORT = qw( compression_is_supported compression_get_list compression_get_property compression_guess_from_filename compression_get_file_extension_regex compression_get_default compression_set_default compression_get_default_level compression_set_default_level compression_is_valid_level ); use Exporter qw(import); use Config; use Dpkg::ErrorHandling; use Dpkg::Gettext; =encoding utf8 =head1 NAME Dpkg::Compression - simple database of available compression methods =head1 DESCRIPTION This modules provides a few public functions and a public regex to interact with the set of supported compression methods. =cut my $COMP = { # Requires gzip >= 1.7 for the --rsyncable option. gzip => { file_ext => 'gz', comp_prog => [ 'gzip', '--no-name', '--rsyncable' ], decomp_prog => [ 'gunzip' ], default_level => 9, }, bzip2 => { file_ext => 'bz2', comp_prog => [ 'bzip2' ], decomp_prog => [ 'bunzip2' ], default_level => 9, }, lzma => { file_ext => 'lzma', comp_prog => [ 'xz', '--format=lzma' ], decomp_prog => [ 'unxz', '--format=lzma' ], default_level => 6, }, xz => { file_ext => 'xz', comp_prog => [ 'xz' ], decomp_prog => [ 'unxz' ], default_level => 6, }, }; my $default_compression = 'xz'; my $default_compression_level = undef; my $regex = join '|', map { $_->{file_ext} } values %$COMP; my $compression_re_file_ext = qr/(?:$regex)/; =head1 FUNCTIONS =over 4 =item @list = compression_get_list() Returns a list of supported compression methods (sorted alphabetically). =cut sub compression_get_list { my @list = sort keys %$COMP; return @list; } =item compression_is_supported($comp) Returns a boolean indicating whether the give compression method is known and supported. =cut sub compression_is_supported { my $comp = shift; return exists $COMP->{$comp}; } =item compression_get_property($comp, $property) Returns the requested property of the compression method. Returns undef if either the property or the compression method doesn't exist. Valid properties currently include "file_ext" for the file extension, "default_level" for the default compression level, "comp_prog" for the name of the compression program and "decomp_prog" for the name of the decompression program. =cut sub compression_get_property { my ($comp, $property) = @_; return unless compression_is_supported($comp); return $COMP->{$comp}{$property} if exists $COMP->{$comp}{$property}; return; } =item compression_guess_from_filename($filename) Returns the compression method that is likely used on the indicated filename based on its file extension. =cut sub compression_guess_from_filename { my $filename = shift; foreach my $comp (compression_get_list()) { my $ext = compression_get_property($comp, 'file_ext'); if ($filename =~ /^(.*)\.\Q$ext\E$/) { return $comp; } } return; } =item $regex = compression_get_file_extension_regex() Returns a regex that matches a file extension of a file compressed with one of the supported compression methods. =cut sub compression_get_file_extension_regex { return $compression_re_file_ext; } =item $comp = compression_get_default() Return the default compression method. It is "xz" unless C<compression_set_default> has been used to change it. =item compression_set_default($comp) Change the default compression method. Errors out if the given compression method is not supported. =cut sub compression_get_default { return $default_compression; } sub compression_set_default { my $method = shift; error(g_('%s is not a supported compression'), $method) unless compression_is_supported($method); $default_compression = $method; } =item $level = compression_get_default_level() Return the default compression level used when compressing data. It's "9" for "gzip" and "bzip2", "6" for "xz" and "lzma", unless C<compression_set_default_level> has been used to change it. =item compression_set_default_level($level) Change the default compression level. Passing undef as the level will reset it to the compressor specific default, otherwise errors out if the level is not valid (see C<compression_is_valid_level>). =cut sub compression_get_default_level { if (defined $default_compression_level) { return $default_compression_level; } else { return compression_get_property($default_compression, 'default_level'); } } sub compression_set_default_level { my $level = shift; error(g_('%s is not a compression level'), $level) if defined($level) and not compression_is_valid_level($level); $default_compression_level = $level; } =item compression_is_valid_level($level) Returns a boolean indicating whether $level is a valid compression level (it must be either a number between 1 and 9 or "fast" or "best") =cut sub compression_is_valid_level { my $level = shift; return $level =~ /^([1-9]|fast|best)$/; } =back =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() Deprecated variables: $default_compression, $default_compression_level and $compression_re_file_ext =head2 Version 1.01 (dpkg 1.16.1) Default compression level is not global any more, it is per compressor type. =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! ���Q@ Q@ Vendor/Debian.pmnu �[��� # Copyright © 2009-2011 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2009, 2011-2017 Guillem Jover <guillem@debian.org> # # Hardening build flags handling derived from work of: # Copyright © 2009-2011 Kees Cook <kees@debian.org> # Copyright © 2007-2008 Canonical, Ltd. # # 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::Vendor::Debian; use strict; use warnings; our $VERSION = '0.01'; use Dpkg; use Dpkg::Arch; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Control::Types; use parent qw(Dpkg::Vendor::Default); =encoding utf8 =head1 NAME Dpkg::Vendor::Debian - Debian vendor class =head1 DESCRIPTION This vendor class customizes the behaviour of dpkg scripts for Debian specific behavior and policies. =cut sub run_hook { my ($self, $hook, @params) = @_; if ($hook eq 'package-keyrings') { return ('/usr/share/keyrings/debian-keyring.gpg', '/usr/share/keyrings/debian-nonupload.gpg', '/usr/share/keyrings/debian-maintainers.gpg'); } elsif ($hook eq 'archive-keyrings') { return ('/usr/share/keyrings/debian-archive-keyring.gpg'); } elsif ($hook eq 'archive-keyrings-historic') { return ('/usr/share/keyrings/debian-archive-removed-keys.gpg'); } elsif ($hook eq 'builtin-build-depends') { return qw(build-essential:native); } elsif ($hook eq 'builtin-build-conflicts') { return (); } elsif ($hook eq 'register-custom-fields') { } elsif ($hook eq 'extend-patch-header') { my ($textref, $ch_info) = @params; if ($ch_info->{'Closes'}) { foreach my $bug (split(/\s+/, $ch_info->{'Closes'})) { $$textref .= "Bug-Debian: https://bugs.debian.org/$bug\n"; } } # XXX: Layer violation... require Dpkg::Vendor::Ubuntu; my $b = Dpkg::Vendor::Ubuntu::find_launchpad_closes($ch_info->{'Changes'}); foreach my $bug (@$b) { $$textref .= "Bug-Ubuntu: https://bugs.launchpad.net/bugs/$bug\n"; } } elsif ($hook eq 'update-buildflags') { $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(); } elsif ($hook eq 'sanitize-environment') { # Reset umask to a sane default. umask 0022; # Reset locale to a sane default. $ENV{LC_COLLATE} = 'C.UTF-8'; } else { return $self->SUPER::run_hook($hook, @params); } } sub _lto_disabled { my $fn = "/usr/share/lto-disabled-list/lto-disabled-list"; open(LIST, "<", $fn) or return; # get source name -r "debian/control" or return; require Dpkg::Control::Info; my $ctrl = Dpkg::Control::Info->new(); my $src_fields = $ctrl->get_source(); return unless defined $src_fields; my $src = ""; foreach (keys %{$src_fields}) { my $v = $src_fields->{$_}; if (m/^Source$/i) { $src = $v; last; } } return unless $src ne ""; my $arch = Dpkg::Arch::get_host_arch(); # read disabled-list while (<LIST>) { if (m/^$src\s/) { if (m/^$src\s.*(any|$arch)\s/) { close(LIST); return 1; } else { close(LIST); return; } } } close(LIST); return; } sub _add_build_flags { my ($self, $flags) = @_; # Default feature states. my %use_feature = ( future => { lfs => 0, }, qa => { bug => 0, canary => 0, }, reproducible => { timeless => 1, fixfilepath => 1, fixdebugpath => 1, }, optimize => { lto => 0, }, optimize => { lto => 0, }, sanitize => { address => 0, thread => 0, leak => 0, undefined => 0, }, hardening => { # XXX: This is set to undef so that we can cope with the brokenness # of gcc managing this feature builtin. pie => undef, stackprotector => 1, stackprotectorstrong => 1, fortify => 1, format => 1, relro => 1, bindnow => 0, }, ); # no hook to set in Ubuntu.pm require Dpkg::Arch; my $arch = Dpkg::Arch::get_host_arch(); if (Dpkg::Arch::debarch_eq($arch, 'amd64') or Dpkg::Arch::debarch_eq($arch, 'arm64') or Dpkg::Arch::debarch_eq($arch, 'ppc64el') or Dpkg::Arch::debarch_eq($arch, 's390x')) { $use_feature{optimize}{lto} = 1; if (_lto_disabled()) { $use_feature{optimize}{lto} = 0; } } my %builtin_feature = ( hardening => { pie => 1, }, ); ## 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) { $opts_build->parse_features($area, $use_feature{$area}); $opts_maint->parse_features($area, $use_feature{$area}); } my ($abi, $libc, $os, $cpu) = Dpkg::Arch::debarch_to_debtuple($arch); unless (defined $abi and defined $libc and defined $os and defined $cpu) { warning(g_("unknown host architecture '%s'"), $arch); ($abi, $os, $cpu) = ('', '', ''); } ## Global defaults my @compile_flags = qw( CFLAGS CXXFLAGS OBJCFLAGS OBJCXXFLAGS FFLAGS FCFLAGS GCJFLAGS ); my $default_flags; my $default_d_flags; if ($opts_build->has('noopt')) { $default_flags = '-g -O0'; $default_d_flags = '-fdebug'; } else { $default_flags = '-g -O2'; $default_d_flags = '-frelease'; } $flags->append($_, $default_flags) foreach @compile_flags; $flags->append('DFLAGS', $default_d_flags); ## Area: future if ($use_feature{future}{lfs}) { my ($abi_bits, $abi_endian) = Dpkg::Arch::debarch_to_abiattrs($arch); my $cpu_bits = Dpkg::Arch::debarch_to_cpubits($arch); if ($abi_bits == 32 and $cpu_bits == 32) { $flags->append('CPPFLAGS', '-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'); } } ## Area: qa # Warnings that detect actual bugs. if ($use_feature{qa}{bug}) { # 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"); } } # Inject dummy canary options to detect issues with build flag propagation. if ($use_feature{qa}{canary}) { require Digest::MD5; my $id = Digest::MD5::md5_hex(int rand 4096); foreach my $flag (qw(CPPFLAGS CFLAGS OBJCFLAGS CXXFLAGS OBJCXXFLAGS)) { $flags->append($flag, "-D__DEB_CANARY_${flag}_${id}__"); } $flags->append('LDFLAGS', "-Wl,-z,deb-canary-${id}"); } ## Area: reproducible my $build_path; # Mask features that might have an unsafe usage. if ($use_feature{reproducible}{fixfilepath} or $use_feature{reproducible}{fixdebugpath}) { require 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{reproducible}{fixfilepath} = 0; $use_feature{reproducible}{fixdebugpath} = 0; } } # Warn when the __TIME__, __DATE__ and __TIMESTAMP__ macros are used. if ($use_feature{reproducible}{timeless}) { $flags->append('CPPFLAGS', '-Wdate-time'); } # 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($_, $map) foreach @compile_flags; } ## Area: optimize if ($use_feature{optimize}{lto}) { my $flag = '-flto=auto -ffat-lto-objects'; $flags->append($_, $flag) foreach (@compile_flags, 'LDFLAGS'); } ## Area: optimize if ($use_feature{optimize}{lto}) { my $ltoflag = '-flto=auto -ffat-lto-objects'; $flags->append('CFLAGS', $ltoflag); $flags->append('CXXFLAGS', $ltoflag); $flags->append('OBJCFLAGS', $ltoflag); $flags->append('OBJCXXFLAGS', $ltoflag); $flags->append('FFLAGS', $ltoflag); $flags->append('FCFLAGS', $ltoflag); $flags->append('LDFLAGS', '-flto=auto'); } ## Area: sanitize # Handle logical feature interactions. if ($use_feature{sanitize}{address} and $use_feature{sanitize}{thread}) { # Disable the thread sanitizer when the address one is active, they # are mutually incompatible. $use_feature{sanitize}{thread} = 0; } if ($use_feature{sanitize}{address} or $use_feature{sanitize}{thread}) { # Disable leak sanitizer, it is implied by the address or thread ones. $use_feature{sanitize}{leak} = 0; } if ($use_feature{sanitize}{address}) { my $flag = '-fsanitize=address -fno-omit-frame-pointer'; $flags->append('CFLAGS', $flag); $flags->append('CXXFLAGS', $flag); $flags->append('LDFLAGS', '-fsanitize=address'); } if ($use_feature{sanitize}{thread}) { my $flag = '-fsanitize=thread'; $flags->append('CFLAGS', $flag); $flags->append('CXXFLAGS', $flag); $flags->append('LDFLAGS', $flag); } if ($use_feature{sanitize}{leak}) { $flags->append('LDFLAGS', '-fsanitize=leak'); } if ($use_feature{sanitize}{undefined}) { my $flag = '-fsanitize=undefined'; $flags->append('CFLAGS', $flag); $flags->append('CXXFLAGS', $flag); $flags->append('LDFLAGS', $flag); } ## Area: hardening # Mask builtin features that are not enabled by default in the compiler. my %builtin_pie_arch = map { $_ => 1 } qw( 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; } # Mask features that are not available on certain architectures. if ($os !~ /^(?:linux|kfreebsd|knetbsd|hurd)$/ or $cpu =~ /^(?:hppa|avr32)$/) { # Disabled on non-(linux/kfreebsd/knetbsd/hurd). # Disabled on hppa, avr32 # (#574716). $use_feature{hardening}{pie} = 0; } if ($cpu =~ /^(?:ia64|alpha|hppa|nios2)$/ or $arch eq 'arm') { # Stack protector disabled on ia64, alpha, hppa, nios2. # "warning: -fstack-protector not supported for this target" # Stack protector disabled on arm (ok on armel). # compiler supports it incorrectly (leads to SEGV) $use_feature{hardening}{stackprotector} = 0; } if ($cpu =~ /^(?:ia64|hppa|avr32)$/) { # relro not implemented on ia64, hppa, avr32. $use_feature{hardening}{relro} = 0; } # Mask features that might be influenced by other flags. if ($opts_build->has('noopt')) { # glibc 2.16 and later warn when using -O0 and _FORTIFY_SOURCE. $use_feature{hardening}{fortify} = 0; } # Handle logical feature interactions. if ($use_feature{hardening}{relro} == 0) { # Disable bindnow if relro is not enabled, since it has no # hardening ability without relro and may incur load penalties. $use_feature{hardening}{bindnow} = 0; } if ($use_feature{hardening}{stackprotector} == 0) { # Disable stackprotectorstrong if stackprotector is disabled. $use_feature{hardening}{stackprotectorstrong} = 0; } # PIE if (defined $use_feature{hardening}{pie} and $use_feature{hardening}{pie} and not $builtin_feature{hardening}{pie}) { my $flag = "-specs=$Dpkg::DATADIR/pie-compile.specs"; $flags->append($_, $flag) foreach @compile_flags; $flags->append('LDFLAGS', "-specs=$Dpkg::DATADIR/pie-link.specs"); } elsif (defined $use_feature{hardening}{pie} and not $use_feature{hardening}{pie} and $builtin_feature{hardening}{pie}) { my $flag = "-specs=$Dpkg::DATADIR/no-pie-compile.specs"; $flags->append($_, $flag) foreach @compile_flags; $flags->append('LDFLAGS', "-specs=$Dpkg::DATADIR/no-pie-link.specs"); } # Stack protector if ($use_feature{hardening}{stackprotectorstrong}) { my $flag = '-fstack-protector-strong'; $flags->append($_, $flag) foreach @compile_flags; } elsif ($use_feature{hardening}{stackprotector}) { my $flag = '-fstack-protector --param=ssp-buffer-size=4'; $flags->append($_, $flag) foreach @compile_flags; } # Fortify Source if ($use_feature{hardening}{fortify}) { $flags->append('CPPFLAGS', '-D_FORTIFY_SOURCE=2'); } # Format Security if ($use_feature{hardening}{format}) { my $flag = '-Wformat -Werror=format-security'; $flags->append('CFLAGS', $flag); $flags->append('CXXFLAGS', $flag); $flags->append('OBJCFLAGS', $flag); $flags->append('OBJCXXFLAGS', $flag); } # Read-only Relocations if ($use_feature{hardening}{relro}) { $flags->append('LDFLAGS', '-Wl,-z,relro'); } # Bindnow if ($use_feature{hardening}{bindnow}) { $flags->append('LDFLAGS', '-Wl,-z,now'); } ## Commit # Set used features to their builtin setting if unset. foreach my $area (sort keys %builtin_feature) { foreach my $feature (keys %{$builtin_feature{$area}}) { $use_feature{$area}{$feature} //= $builtin_feature{$area}{$feature}; } } # Store the feature usage. foreach my $area (sort keys %use_feature) { while (my ($feature, $enabled) = each %{$use_feature{$area}}) { $flags->set_feature($area, $feature, $enabled); } } } 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" or $linkname eq "/usr$pathname") { $tainted{'merged-usr-via-aliased-dirs'} = 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 This is a private module. =cut 1; PK ! �{�� � Vendor/Default.pmnu �[��� # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Vendor::Default; use strict; use warnings; our $VERSION = '0.01'; # If you use this file as template to create a new vendor class, please # uncomment the following lines #use parent qw(Dpkg::Vendor::Default); =encoding utf8 =head1 NAME Dpkg::Vendor::Default - default vendor class =head1 DESCRIPTION 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). It provides some hooks that are called by various dpkg-* tools. If you need a new hook, please file a bug against dpkg-dev and explain your need. Note that the hook API has no guarantee to be stable over an extended period of time. If you run an important distribution that makes use of vendor hooks, you'd better submit them for integration so that we avoid breaking your code. =head1 METHODS =over 4 =item $vendor_obj = Dpkg::Vendor::Default->new() Creates the default vendor object. Can be inherited by all vendor objects if they don't need any specific initialization at object creation time. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = {}; bless $self, $class; return $self; } =item $vendor_obj->run_hook($id, @params) Run the corresponding hook. The parameters are hook-specific. The supported hooks are: =over 8 =item before-source-build ($srcpkg) The first parameter is a Dpkg::Source::Package object. The hook is called just before the execution of $srcpkg->build(). =item package-keyrings () The hook is called when dpkg-source is checking a signature on a source package (since dpkg 1.18.11). It takes no parameters, but returns a (possibly empty) list of vendor-specific keyrings. =item archive-keyrings () The hook is called when there is a need to check signatures on artifacts from repositories, for example by a download method (since dpkg 1.18.11). It takes no parameters, but returns a (possibly empty) list of vendor-specific keyrings. =item archive-keyrings-historic () The hook is called when there is a need to check signatures on artifacts from historic repositories, for example by a download method (since dpkg 1.18.11). It takes no parameters, but returns a (possibly empty) list of vendor-specific keyrings. =item builtin-build-depends () The hook is called when dpkg-checkbuilddeps is initializing the source package build dependencies (since dpkg 1.18.2). It takes no parameters, but returns a (possibly empty) list of vendor-specific B<Build-Depends>. =item builtin-build-conflicts () The hook is called when dpkg-checkbuilddeps is initializing the source package build conflicts (since dpkg 1.18.2). It takes no parameters, but returns a (possibly empty) list of vendor-specific B<Build-Conflicts>. =item register-custom-fields () The hook is called in Dpkg::Control::Fields to register custom fields. You should return a list of arrays. Each array is an operation to perform. The first item is the name of the operation and corresponds to a field_* function provided by Dpkg::Control::Fields. The remaining fields are the parameters that are passed unchanged to the corresponding function. Known operations are "register", "insert_after" and "insert_before". =item post-process-changelog-entry ($fields) The hook is called in Dpkg::Changelog to post-process a Dpkg::Changelog::Entry after it has been created and filled with the appropriate values. =item update-buildflags ($flags) The hook is called in Dpkg::BuildFlags to allow the vendor to override the default values set for the various build flags. $flags is a Dpkg::BuildFlags object. =item update-buildprofiles ($build_profiles_ref) The hook is called in Dpkg::BuildProfiles to allow the vendor to override the default values set. $build_profiles_ref is a array ref to Dpkg::BuildProfiles object. =item builtin-system-build-paths () The hook is called by dpkg-genbuildinfo to determine if the current path should be recorded in the B<Build-Path> field (since dpkg 1.18.11). It takes no parameters, but returns a (possibly empty) list of root paths considered acceptable. As an example, if the list contains "/build/", a Build-Path 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). =item sanitize-environment () The hook is called by dpkg-buildpackage to sanitize its build environment (since dpkg 1.20.0). =back =cut sub run_hook { my ($self, $hook, @params) = @_; if ($hook eq 'before-source-build') { my $srcpkg = shift @params; } elsif ($hook eq 'package-keyrings') { return (); } elsif ($hook eq 'archive-keyrings') { return (); } elsif ($hook eq 'archive-keyrings-historic') { return (); } elsif ($hook eq 'register-custom-fields') { return (); } elsif ($hook eq 'builtin-build-depends') { return (); } elsif ($hook eq 'builtin-build-conflicts') { return (); } elsif ($hook eq 'post-process-changelog-entry') { my $fields = shift @params; } elsif ($hook eq 'extend-patch-header') { my ($textref, $ch_info) = @params; } elsif ($hook eq 'update-buildflags') { my $flags = shift @params; } elsif ($hook eq 'update-buildprofiles') { my $build_profiles_ref = shift @params; } elsif ($hook eq 'builtin-system-build-paths') { return (); } elsif ($hook eq 'build-tainted-by') { return (); } elsif ($hook eq 'sanitize-environment') { return; } # Default return value for unknown/unimplemented hooks return; } =back =head1 CHANGES =head2 Version 0.xx This is a private module. =cut 1; PK ! ��Ǯ � Vendor/Ubuntu.pmnu �[��� # Copyright © 2008 Ian Jackson <ijackson@chiark.greenend.org.uk> # Copyright © 2008 Canonical, Ltd. # written by Colin Watson <cjwatson@ubuntu.com> # Copyright © 2008 James Westby <jw+debian@jameswestby.net> # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. package Dpkg::Vendor::Ubuntu; use strict; use warnings; our $VERSION = '0.01'; use Dpkg::ErrorHandling; use Dpkg::Gettext; use Dpkg::Control::Types; use parent qw(Dpkg::Vendor::Debian); =encoding utf8 =head1 NAME Dpkg::Vendor::Ubuntu - Ubuntu vendor class =head1 DESCRIPTION This vendor class customizes the behaviour of dpkg scripts for Ubuntu specific behavior and policies. =cut sub run_hook { my ($self, $hook, @params) = @_; if ($hook eq 'before-source-build') { my $src = shift @params; my $fields = $src->{fields}; # check that Maintainer/XSBC-Original-Maintainer comply to # https://wiki.ubuntu.com/DebianMaintainerField if (defined($fields->{'Version'}) and defined($fields->{'Maintainer'}) and $fields->{'Version'} =~ /ubuntu/) { if ($fields->{'Maintainer'} !~ /(?:ubuntu|canonical)/i) { if (length $ENV{DEBEMAIL} and $ENV{DEBEMAIL} =~ /\@(?:ubuntu|canonical)\.com/) { error(g_('Version number suggests Ubuntu changes, but Maintainer: does not have Ubuntu address')); } else { warning(g_('Version number suggests Ubuntu changes, but Maintainer: does not have Ubuntu address')); } } unless ($fields->{'Original-Maintainer'}) { warning(g_('Version number suggests Ubuntu changes, but there is no XSBC-Original-Maintainer field')); } } } elsif ($hook eq 'package-keyrings') { return ($self->SUPER::run_hook($hook), '/usr/share/keyrings/ubuntu-archive-keyring.gpg'); } elsif ($hook eq 'archive-keyrings') { return ($self->SUPER::run_hook($hook), '/usr/share/keyrings/ubuntu-archive-keyring.gpg'); } elsif ($hook eq 'archive-keyrings-historic') { return ($self->SUPER::run_hook($hook), '/usr/share/keyrings/ubuntu-archive-removed-keys.gpg'); } elsif ($hook eq 'register-custom-fields') { my @field_ops = $self->SUPER::run_hook($hook); push @field_ops, [ 'register', 'Launchpad-Bugs-Fixed', CTRL_FILE_CHANGES | CTRL_CHANGELOG ], [ 'insert_after', CTRL_FILE_CHANGES, 'Closes', 'Launchpad-Bugs-Fixed' ], [ 'insert_after', CTRL_CHANGELOG, 'Closes', 'Launchpad-Bugs-Fixed' ]; return @field_ops; } elsif ($hook eq 'post-process-changelog-entry') { my $fields = shift @params; # Add Launchpad-Bugs-Fixed field my $bugs = find_launchpad_closes($fields->{'Changes'} // ''); if (scalar(@$bugs)) { $fields->{'Launchpad-Bugs-Fixed'} = join(' ', @$bugs); } } elsif ($hook eq 'update-buildopts') { my $build_opts = shift @params; require Dpkg::Arch; my $arch = Dpkg::Arch::get_host_arch(); if (Dpkg::Arch::debarch_eq($arch, 'riscv64')) { $build_opts->set('nocheck', 1, 'riscv64'); } } 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(); if (!$build_opts->has('noopt')) { require Dpkg::Arch; my $arch = Dpkg::Arch::get_host_arch(); if (Dpkg::Arch::debarch_eq($arch, 'ppc64el')) { for my $flag (qw(CFLAGS CXXFLAGS OBJCFLAGS OBJCXXFLAGS GCJFLAGS FFLAGS FCFLAGS)) { my $value = $flags->get($flag); $value =~ s/-O[0-9]/-O3/; $flags->set($flag, $value); } } } # Per https://wiki.ubuntu.com/DistCompilerFlags $flags->prepend('LDFLAGS', '-Wl,-Bsymbolic-functions'); } elsif ($hook eq 'update-buildprofiles') { my $build_profiles_ref = shift @params; unless(grep $_ =~ /^!?noudeb$/, @$build_profiles_ref) { unshift(@$build_profiles_ref, 'noudeb'); } else { # Strip otherwise invalid profile name @$build_profiles_ref = grep { $_ ne "!noudeb" } @$build_profiles_ref; } } else { return $self->SUPER::run_hook($hook, @params); } } =head1 PUBLIC FUNCTIONS =over =item $bugs = Dpkg::Vendor::Ubuntu::find_launchpad_closes($changes) Takes one string as argument and finds "LP: #123456, #654321" statements, which are references to bugs on Launchpad. Returns all closed bug numbers in an array reference. =cut sub find_launchpad_closes { my $changes = shift; my %closes; while ($changes && ($changes =~ /lp:\s+\#\d+(?:,\s*\#\d+)*/pig)) { $closes{$_} = 1 foreach (${^MATCH} =~ /\#?\s?(\d+)/g); } my @closes = sort { $a <=> $b } keys %closes; return \@closes; } =back =head1 CHANGES =head2 Version 0.xx This is a semi-private module. Only documented functions are public. =cut 1; PK ! ��Q�P �P Changelog.pmnu �[��� # Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de> # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <https://www.gnu.org/licenses/>. =encoding utf8 =head1 NAME Dpkg::Changelog - base class to implement a changelog parser =head1 DESCRIPTION Dpkg::Changelog is a class representing a changelog file as an array of changelog entries (Dpkg::Changelog::Entry). By deriving this class and implementing its parse method, you add the ability to fill this object with changelog entries. =cut package Dpkg::Changelog; use strict; use warnings; our $VERSION = '2.00'; use Carp; use Dpkg::Gettext; use Dpkg::ErrorHandling qw(:DEFAULT report REPORT_WARN); use Dpkg::Control; use Dpkg::Control::Changelog; use Dpkg::Control::Fields; use Dpkg::Index; use Dpkg::Version; use Dpkg::Vendor qw(run_vendor_hook); use parent qw(Dpkg::Interface::Storable); use overload '@{}' => sub { return $_[0]->{data} }; =head1 METHODS =over 4 =item $c = Dpkg::Changelog->new(%options) Creates a new changelog object. =cut sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; my $self = { verbose => 1, parse_errors => [] }; bless $self, $class; $self->set_options(%opts); return $self; } =item $c->set_options(%opts) Change the value of some options. "verbose" (defaults to 1) defines whether parse errors are displayed as warnings by default. "reportfile" is a string to use instead of the name of the file parsed, in particular in error messages. "range" defines the range of entries that we want to parse, the parser will stop as soon as it has parsed enough data to satisfy $c->get_range($opts{range}). =cut sub set_options { my ($self, %opts) = @_; $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 previous L<parse> runs. =cut sub reset_parse_errors { my $self = shift; $self->{parse_errors} = []; } =item $c->parse_error($file, $line_nr, $error, [$line]) Record a new parse error in $file at line $line_nr. The error message is specified with $error and a copy of the line can be recorded in $line. =cut sub parse_error { my ($self, $file, $line_nr, $error, $line) = @_; push @{$self->{parse_errors}}, [ $file, $line_nr, $error, $line ]; if ($self->{verbose}) { if ($line) { warning("%20s(l$line_nr): $error\nLINE: $line", $file); } else { warning("%20s(l$line_nr): $error", $file); } } } =item $c->get_parse_errors() Returns all error messages from the last L<parse> run. If called in scalar context returns a human readable string representation. If called in list context returns an array of arrays. Each of these arrays contains =over 4 =item 1. a string describing the origin of the data (a filename usually). If the reportfile configuration option was given, its value will be used instead. =item 2. the line number where the error occurred =item 3. an error description =item 4. the original line =back =cut sub get_parse_errors { my $self = shift; if (wantarray) { return @{$self->{parse_errors}}; } else { my $res = ''; foreach my $e (@{$self->{parse_errors}}) { if ($e->[3]) { $res .= report(REPORT_WARN, g_("%s(l%s): %s\nLINE: %s"), @$e); } else { $res .= report(REPORT_WARN, g_('%s(l%s): %s'), @$e); } } return $res; } } =item $c->set_unparsed_tail($tail) Add a string representing unparsed lines after the changelog entries. Use undef as $tail to remove the unparsed lines currently set. =item $c->get_unparsed_tail() Return a string representing the unparsed lines after the changelog entries. Returns undef if there's no such thing. =cut sub set_unparsed_tail { my ($self, $tail) = @_; $self->{unparsed_tail} = $tail; } sub get_unparsed_tail { my $self = shift; return $self->{unparsed_tail}; } =item @{$c} Returns all the Dpkg::Changelog::Entry objects contained in this changelog in the order in which they have been parsed. =item $c->get_range($range) Returns an array (if called in list context) or a reference to an array of Dpkg::Changelog::Entry objects which each represent one entry of the changelog. $range is a hash reference describing the range of entries to return. See section L<"RANGE SELECTION">. =cut sub __sanity_check_range { my ($self, $r) = @_; my $data = $self->{data}; if (defined($r->{offset}) and not defined($r->{count})) { warning(g_("'offset' without 'count' has no effect")) if $self->{verbose}; delete $r->{offset}; } ## no critic (ControlStructures::ProhibitUntilBlocks) if ((defined($r->{count}) || defined($r->{offset})) && (defined($r->{from}) || defined($r->{since}) || defined($r->{to}) || defined($r->{until}))) { warning(g_("you can't combine 'count' or 'offset' with any other " . 'range option')) if $self->{verbose}; delete $r->{from}; delete $r->{since}; delete $r->{to}; delete $r->{until}; } if (defined($r->{from}) && defined($r->{since})) { warning(g_("you can only specify one of 'from' and 'since', using " . "'since'")) if $self->{verbose}; delete $r->{from}; } if (defined($r->{to}) && defined($r->{until})) { warning(g_("you can only specify one of 'to' and 'until', using " . "'until'")) if $self->{verbose}; delete $r->{to}; } # Handle non-existing versions my (%versions, @versions); foreach my $entry (@{$data}) { my $version = $entry->get_version(); next unless defined $version; $versions{$version->as_string()} = 1; push @versions, $version->as_string(); } if ((defined($r->{since}) and not exists $versions{$r->{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})) { $r->{since} = $v; last; } } if (not exists $versions{$r->{since}}) { # No version was earlier, include all warning(g_('none found, starting from the oldest entry')); delete $r->{since}; $r->{from} = $versions[-1]; } } if ((defined($r->{from}) and not exists $versions{$r->{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) { if (version_compare_relation($v, REL_GT, $r->{from})) { $oldest = $v; } } if (defined($oldest)) { $r->{from} = $oldest; } else { 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 '%s'"), 'until', $r->{until}); warning(g_('use oldest entry that is later than the one specified')); my $oldest; foreach my $v (@versions) { if (version_compare_relation($v, REL_GT, $r->{until})) { $oldest = $v; } } if (defined($oldest)) { $r->{until} = $oldest; } else { 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 '%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})) { $r->{to} = $v; last; } } if (not exists $versions{$r->{to}}) { # No version was earlier 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 '%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 '%s', ignoring"), $r->{until}); delete $r->{until}; } ## use critic } sub get_range { my ($self, $range) = @_; $range //= {}; my $res = $self->_data_range($range); return unless defined $res; if (wantarray) { return reverse @{$res} if $range->{reverse}; return @{$res}; } else { return $res; } } sub _is_full_range { my ($self, $range) = @_; return 1 if $range->{all}; # If no range delimiter is specified, we want everything. foreach my $delim (qw(since until from to count offset)) { return 0 if exists $range->{$delim}; } return 1; } sub _data_range { my ($self, $range) = @_; my $data = $self->{data} or return; return [ @$data ] if $self->_is_full_range($range); $self->__sanity_check_range($range); my ($start, $end); if (defined($range->{count})) { my $offset = $range->{offset} // 0; my $count = $range->{count}; # Convert count/offset in start/end if ($offset > 0) { $offset -= ($count < 0); } elsif ($offset < 0) { $offset = $#$data + ($count > 0) + $offset; } else { $offset = $#$data if $count < 0; } $start = $end = $offset; $start += $count+1 if $count < 0; $end += $count-1 if $count > 0; # Check limits $start = 0 if $start < 0; return if $start > $#$data; $end = $#$data if $end > $#$data; return if $end < 0; $end = $start if $end < $start; return [ @{$data}[$start .. $end] ]; } ## no critic (ControlStructures::ProhibitUntilBlocks) my @result; my $include = 1; $include = 0 if defined($range->{to}) or defined($range->{until}); foreach my $entry (@{$data}) { my $v = $entry->get_version(); $include = 1 if defined($range->{to}) and $v eq $range->{to}; last if defined($range->{since}) and $v eq $range->{since}; push @result, $entry if $include; $include = 1 if defined($range->{until}) and $v eq $range->{until}; last if defined($range->{from}) and $v eq $range->{from}; } ## use critic return \@result if scalar(@result); return; } =item $c->abort_early() Returns true if enough data have been parsed to be able to return all entries selected by the range set at creation (or with set_options). =cut sub abort_early { my $self = shift; my $data = $self->{data} or return; my $r = $self->{range} or return; my $count = $r->{count} // 0; my $offset = $r->{offset} // 0; return if $self->_is_full_range($r); return if $offset < 0 or $count < 0; if (defined($r->{count})) { if ($offset > 0) { $offset -= ($count < 0); } my $start = my $end = $offset; $end += $count-1 if $count > 0; return ($start < @$data and $end < @$data); } return unless defined($r->{since}) or defined($r->{from}); foreach my $entry (@{$data}) { my $v = $entry->get_version(); return 1 if defined($r->{since}) and $v eq $r->{since}; return 1 if defined($r->{from}) and $v eq $r->{from}; } return; } =item $str = $c->output() =item "$c" Returns a string representation of the changelog (it's a concatenation of the string representation of the individual changelog entries). =item $c->output($fh) Output the changelog to the given filehandle. =cut sub output { my ($self, $fh) = @_; my $str = ''; foreach my $entry (@{$self}) { my $text = $entry->output(); print { $fh } $text if defined $fh; $str .= $text if defined wantarray; } my $text = $self->get_unparsed_tail(); if (defined $text) { print { $fh } $text if defined $fh; $str .= $text if defined wantarray; } 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); my $i = 1; %URGENCIES = map { $_ => $i++ } @URGENCIES; } sub _format_dpkg { my ($self, $range) = @_; my @data = $self->get_range($range) or return; my $src = shift @data; my $f = Dpkg::Control::Changelog->new(); $f->{Urgency} = $src->get_urgency() || 'unknown'; $f->{Source} = $src->get_source() || 'unknown'; $f->{Version} = $src->get_version() // 'unknown'; $f->{Distribution} = join(' ', $src->get_distributions()); $f->{Maintainer} = $src->get_maintainer() // ''; $f->{Date} = $src->get_timestamp() // ''; $f->{Timestamp} = $src->get_timepiece && $src->get_timepiece->epoch // ''; $f->{Changes} = $src->get_dpkg_changes(); # handle optional fields my $opts = $src->get_optional_fields(); my %closes; foreach (keys %$opts) { if (/^Urgency$/i) { # Already dealt } elsif (/^Closes$/i) { $closes{$_} = 1 foreach (split(/\s+/, $opts->{Closes})); } else { field_transfer_single($opts, $f); } } foreach my $bin (@data) { my $oldurg = $f->{Urgency} // ''; my $oldurgn = $URGENCIES{$f->{Urgency}} // -1; my $newurg = $bin->get_urgency() // ''; my $newurgn = $URGENCIES{$newurg} // -1; $f->{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg; $f->{Changes} .= "\n" . $bin->get_dpkg_changes(); # handle optional fields $opts = $bin->get_optional_fields(); foreach (keys %$opts) { if (/^Closes$/i) { $closes{$_} = 1 foreach (split(/\s+/, $opts->{Closes})); } elsif (not exists $f->{$_}) { # Don't overwrite an existing field field_transfer_single($opts, $f); } } } if (scalar keys %closes) { $f->{Closes} = join ' ', sort { $a <=> $b } keys %closes; } run_vendor_hook('post-process-changelog-entry', $f); return $f; } sub _format_rfc822 { my ($self, $range) = @_; my @data = $self->get_range($range) or return; my @ctrl; foreach my $entry (@data) { my $f = Dpkg::Control::Changelog->new(); $f->{Urgency} = $entry->get_urgency() || 'unknown'; $f->{Source} = $entry->get_source() || 'unknown'; $f->{Version} = $entry->get_version() // 'unknown'; $f->{Distribution} = join(' ', $entry->get_distributions()); $f->{Maintainer} = $entry->get_maintainer() // ''; $f->{Date} = $entry->get_timestamp() // ''; $f->{Timestamp} = $entry->get_timepiece && $entry->get_timepiece->epoch // ''; $f->{Changes} = $entry->get_dpkg_changes(); # handle optional fields my $opts = $entry->get_optional_fields(); foreach (keys %$opts) { field_transfer_single($opts, $f) unless exists $f->{$_}; } run_vendor_hook('post-process-changelog-entry', $f); push @ctrl, $f; } return @ctrl; } =item $control = $c->format_range($format, $range) Formats the changelog into Dpkg::Control::Changelog objects representing the entries selected by the optional range specifier (see L<"RANGE SELECTION"> for details). In scalar context returns a Dpkg::Index object containing the selected entries, in list context returns an array of Dpkg::Control::Changelog objects. With format B<dpkg> the returned Dpkg::Control::Changelog object is coalesced from the entries in the changelog that are part of the range requested, with the fields described below, but considering that "selected entry" means the first entry of the selected range. With format B<rfc822> each returned Dpkg::Control::Changelog objects represents one entry in the changelog that is part of the range requested, with the fields described below, but considering that "selected entry" means for each entry. The different formats return undef if no entries are matched. The following fields are contained in the object(s) returned: =over 4 =item Source package name (selected entry) =item Version packages' version (selected entry) =item Distribution target distribution (selected entry) =item Urgency urgency (highest of all entries in range) =item Maintainer person that created the (selected) entry =item Date date of the (selected) entry =item Timestamp date of the (selected) entry as a timestamp in seconds since the epoch =item Closes bugs closed by the (selected) entry/entries, sorted by bug number =item Changes content of the (selected) entry/entries =back =cut sub format_range { my ($self, $format, $range) = @_; my @ctrl; if ($format eq 'dpkg') { @ctrl = $self->_format_dpkg($range); } elsif ($format eq 'rfc822') { @ctrl = $self->_format_rfc822($range); } else { croak "unknown changelog output format $format"; } if (wantarray) { return @ctrl; } else { my $index = Dpkg::Index->new(type => CTRL_CHANGELOG); foreach my $f (@ctrl) { $index->add($f); } return $index; } } =back =head1 RANGE SELECTION A range selection is described by a hash reference where the allowed keys and values are described below. The following options take a version number as value. =over 4 =item since Causes changelog information from all versions strictly later than B<version> to be used. =item until Causes changelog information from all versions strictly earlier than B<version> to be used. =item from Similar to C<since> but also includes the information for the specified B<version> itself. =item to Similar to C<until> but also includes the information for the specified B<version> itself. =back The following options don't take version numbers as values: =over 4 =item all If set to a true value, all entries of the changelog are returned, this overrides all other options. =item count Expects a signed integer as value. Returns C<value> entries from the top of the changelog if set to a positive integer, and C<abs(value)> entries from the tail if set to a negative integer. =item offset Expects a signed integer as value. Changes the starting point for C<count>, either counted from the top (positive integer) or from the tail (negative integer). C<offset> has no effect if C<count> wasn't given as well. =back Some examples for the above options. Imagine an example changelog with entries for the versions 1.2, 1.3, 2.0, 2.1, 2.2, 3.0 and 3.1. Range Included entries ----- ---------------- since => '2.0' 3.1, 3.0, 2.2 until => '2.0' 1.3, 1.2 from => '2.0' 3.1, 3.0, 2.2, 2.1, 2.0 to => '2.0' 2.0, 1.3, 1.2 count => 2 3.1, 3.0 count => -2 1.3, 1.2 count => 3, offset => 2 2.2, 2.1, 2.0 count => 2, offset => -3 2.0, 1.3 count => -2, offset => 3 3.0, 2.2 count => -2, offset => -3 2.2, 2.1 Any combination of one option of C<since> and C<from> and one of C<until> and C<to> returns the intersection of the two results 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(). Deprecated methods: $c->dpkg(), $c->rfc822(). New field Timestamp in output formats. =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! O�eZ� � Exit.pmnu �[��� # Copyright © 2002 Adam Heath <doogie@debian.org> # Copyright © 2012-2013 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::Exit; use strict; use warnings; our $VERSION = '2.00'; our @EXPORT_OK = qw( push_exit_handler pop_exit_handler run_exit_handlers ); use Exporter qw(import); my @handlers = (); =encoding utf8 =head1 NAME Dpkg::Exit - program exit handlers =head1 DESCRIPTION The Dpkg::Exit module provides support functions to run handlers on exit. =head1 FUNCTIONS =over 4 =item push_exit_handler($func) Register a code reference into the exit function handlers stack. =cut sub push_exit_handler { my ($func) = shift; _setup_exit_handlers() if @handlers == 0; push @handlers, $func; } =item pop_exit_handler() Pop the last registered exit handler from the handlers stack. =cut sub pop_exit_handler { _reset_exit_handlers() if @handlers == 1; pop @handlers; } =item run_exit_handlers() Run the registered exit handlers. =cut sub run_exit_handlers { while (my $handler = pop @handlers) { $handler->(); } _reset_exit_handlers(); } sub _exit_handler { run_exit_handlers(); exit(127); } my @SIGNAMES = qw(INT HUP QUIT); 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}; } } END { local $?; run_exit_handlers(); } =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() Deprecated variable: @handlers =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! �� �@- @- Index.pmnu �[��� # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2012-2017 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::Index; use strict; use warnings; our $VERSION = '2.01'; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Control; use parent qw(Dpkg::Interface::Storable); use overload '@{}' => sub { return $_[0]->{order} }, fallback => 1; =encoding utf8 =head1 NAME Dpkg::Index - generic index of control information =head1 DESCRIPTION This class represent a set of Dpkg::Control objects. =head1 METHODS =over 4 =item $index = Dpkg::Index->new(%opts) Creates a new empty index. See set_options() for more details. =cut sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; my $self = { items => {}, order => [], unique_tuple_key => 1, get_key_func => sub { return $_[0]->{Package} }, type => CTRL_UNKNOWN, item_opts => {}, }; bless $self, $class; $self->set_options(%opts); if (exists $opts{load}) { $self->load($opts{load}); } return $self; } =item $index->set_options(%opts) 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 true), "item_opts" is a hash reference that will be passed to the item constructor in the new_item() method. The index can only contain one item with a given key. The "get_key_func" function used depends on the type: =over =item * for CTRL_INFO_SRC, it is the Source field; =item * 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 * for CTRL_INFO_PKG it is simply the Package field; =item * 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 * for CTRL_CHANGELOG it is the Source and the Version fields (concatenated with an intermediary "_"); =item * for CTRL_TESTS is either the Tests or Test-Command fields; =item * for CTRL_FILE_CHANGES it is the Source, Version and Architecture fields (concatenated with "_"); =item * for CTRL_FILE_VENDOR it is the Vendor field; =item * for CTRL_FILE_STATUS it is the Package and Architecture fields (concatenated with "_"); =item * otherwise it is the Package field by default. =back =cut sub set_options { my ($self, %opts) = @_; # Default values based on type if (exists $opts{type}) { my $t = $opts{type}; if ($t == CTRL_INFO_PKG) { $self->{get_key_func} = sub { return $_[0]->{Package}; }; } elsif ($t == CTRL_INFO_SRC) { $self->{get_key_func} = sub { return $_[0]->{Source}; }; } elsif ($t == CTRL_CHANGELOG) { $self->{get_key_func} = sub { return $_[0]->{Source} . '_' . $_[0]->{Version}; }; } elsif ($t == CTRL_COPYRIGHT_HEADER) { # This is a bit pointless, because the value will almost always # be the same, but guarantees that we use a known field. $self->{get_key_func} = sub { return $_[0]->{Format}; }; } elsif ($t == CTRL_COPYRIGHT_FILES) { $self->{get_key_func} = sub { return $_[0]->{Files}; }; } elsif ($t == CTRL_COPYRIGHT_LICENSE) { $self->{get_key_func} = sub { return $_[0]->{License}; }; } elsif ($t == CTRL_TESTS) { $self->{get_key_func} = sub { return $_[0]->{Tests} || $_[0]->{'Test-Command'}; }; } elsif ($t == CTRL_INDEX_SRC or $t == CTRL_PKG_SRC) { if ($opts{unique_tuple_key} // $self->{unique_tuple_key}) { $self->{get_key_func} = sub { return $_[0]->{Package} . '_' . $_[0]->{Version}; }; } else { $self->{get_key_func} = sub { return $_[0]->{Package}; }; } } elsif ($t == CTRL_INDEX_PKG or $t == CTRL_PKG_DEB) { if ($opts{unique_tuple_key} // $self->{unique_tuple_key}) { $self->{get_key_func} = sub { return $_[0]->{Package} . '_' . $_[0]->{Version} . '_' . $_[0]->{Architecture}; }; } else { $self->{get_key_func} = sub { return $_[0]->{Package}; }; } } elsif ($t == CTRL_FILE_CHANGES) { $self->{get_key_func} = sub { return $_[0]->{Source} . '_' . $_[0]->{Version} . '_' . $_[0]->{Architecture}; }; } elsif ($t == CTRL_FILE_VENDOR) { $self->{get_key_func} = sub { return $_[0]->{Vendor}; }; } elsif ($t == CTRL_FILE_STATUS) { $self->{get_key_func} = sub { return $_[0]->{Package} . '_' . $_[0]->{Architecture}; }; } } # Options set by the user override default values $self->{$_} = $opts{$_} foreach keys %opts; } =item $index->get_type() Returns the type of control information stored. See the type parameter set during new(). =cut sub get_type { my $self = shift; return $self->{type}; } =item $index->add($item, [$key]) Add a new item in the index. If the $key parameter is omitted, the key will be generated with the get_key_func function (see set_options() for details). =cut sub add { my ($self, $item, $key) = @_; $key //= $self->{get_key_func}($item); if (not exists $self->{items}{$key}) { push @{$self->{order}}, $key; } $self->{items}{$key} = $item; } =item $index->parse($fh, $desc) Reads the filehandle and creates all items parsed. When called multiple times, the parsed stanzas are accumulated. Returns the number of items parsed. =cut sub parse { my ($self, $fh, $desc) = @_; my $item = $self->new_item(); my $i = 0; while ($item->parse($fh, $desc)) { $self->add($item); $item = $self->new_item(); $i++; } return $i; } =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 $item = $index->new_item() Creates a new item. Mainly useful for derived objects that would want to override this method to return something else than a Dpkg::Control object. =cut sub new_item { my $self = shift; return Dpkg::Control->new(%{$self->{item_opts}}, type => $self->{type}); } =item $item = $index->get_by_key($key) Returns the item identified by $key or undef. =cut sub get_by_key { my ($self, $key) = @_; return $self->{items}{$key} if exists $self->{items}{$key}; return; } =item @keys = $index->get_keys(%criteria) Returns the keys of items that matches all the criteria. The key of the %criteria hash is a field name and the value is either a regex that needs to match the field value, or a reference to a function that must return true and that receives the field value as single parameter, or a scalar that must be equal to the field value. =cut sub get_keys { my ($self, %crit) = @_; my @selected = @{$self->{order}}; foreach my $s_crit (keys %crit) { # search criteria if (ref($crit{$s_crit}) eq 'Regexp') { @selected = grep { exists $self->{items}{$_}{$s_crit} and $self->{items}{$_}{$s_crit} =~ $crit{$s_crit} } @selected; } elsif (ref($crit{$s_crit}) eq 'CODE') { @selected = grep { $crit{$s_crit}->($self->{items}{$_}{$s_crit}); } @selected; } else { @selected = grep { exists $self->{items}{$_}{$s_crit} and $self->{items}{$_}{$s_crit} eq $crit{$s_crit} } @selected; } } return @selected; } =item @items = $index->get(%criteria) Returns all the items that matches all the criteria. =cut sub get { my ($self, %crit) = @_; return map { $self->{items}{$_} } $self->get_keys(%crit); } =item $index->remove_by_key($key) Remove the item identified by the given key. =cut sub remove_by_key { my ($self, $key) = @_; @{$self->{order}} = grep { $_ ne $key } @{$self->{order}}; return delete $self->{items}{$key}; } =item @items = $index->remove(%criteria) Returns and removes all the items that matches all the criteria. =cut sub remove { my ($self, %crit) = @_; my @keys = $self->get_keys(%crit); my (%keys, @ret); foreach my $key (@keys) { $keys{$key} = 1; push @ret, $self->{items}{$key} if defined wantarray; delete $self->{items}{$key}; } @{$self->{order}} = grep { not exists $keys{$_} } @{$self->{order}}; return @ret; } =item $index->merge($other_index, %opts) Merge the entries of the other index. While merging, the keys of the merged index are used, they are not re-computed (unless you have set the options "keep_keys" to "0"). It's your responsibility to ensure that they have been computed with the same function. =cut sub merge { my ($self, $other, %opts) = @_; $opts{keep_keys} //= 1; foreach my $key ($other->get_keys()) { $self->add($other->get_by_key($key), $opts{keep_keys} ? $key : undef); } } =item $index->sort(\&sortfunc) Sort the index with the given sort function. If no function is given, an alphabetic sort is done based on the keys. The sort function receives the items themselves as parameters and not the keys. =cut sub sort { my ($self, $func) = @_; if (defined $func) { @{$self->{order}} = sort { $func->($self->{items}{$a}, $self->{items}{$b}) } @{$self->{order}}; } else { @{$self->{order}} = sort @{$self->{order}}; } } =item $str = $index->output([$fh]) =item "$index" 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(). Print the string representation of the index to a filehandle if $fh has been passed. =cut sub output { my ($self, $fh) = @_; my $str = ''; foreach my $key ($self->get_keys()) { if (defined $fh) { print { $fh } $self->get_by_key($key) . "\n"; } if (defined wantarray) { $str .= $self->get_by_key($key) . "\n"; } } 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.01 (dpkg 1.20.6) New option: Add new "item_opts" option. =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 better default "get_key_func" options, which will become the default behavior in 1.20.x. =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut 1; PK ! �4;�� � Deps/KnownFacts.pmnu �[��� # 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; PK ! H?DZ Deps/Multiple.pmnu �[��� # 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; PK ! bOF�� � Deps/OR.pmnu �[��� # 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; PK ! zN7$�G �G Deps/Simple.pmnu �[��� # 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; PK ! �\�,� � Deps/Union.pmnu �[��� # 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; PK ! S�� g g Deps/AND.pmnu �[��� # 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; PK ! /�UV UV Shlibs/SymbolFile.pmnu �[��� # Copyright © 2007 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2009-2010 Modestas Vainius <modax@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::Shlibs::SymbolFile; use strict; use warnings; our $VERSION = '0.01'; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Version; use Dpkg::Control::Fields; use Dpkg::Shlibs::Symbol; 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 %internal_symbol = ( __bss_end__ => 1, # arm __bss_end => 1, # arm _bss_end__ => 1, # arm __bss_start => 1, # ALL __bss_start__ => 1, # arm __data_start => 1, # arm __do_global_ctors_aux => 1, # ia64 __do_global_dtors_aux => 1, # ia64 __do_jv_register_classes => 1, # ia64 _DYNAMIC => 1, # ALL _edata => 1, # ALL _end => 1, # ALL __end__ => 1, # arm __exidx_end => 1, # armel __exidx_start => 1, # armel _fbss => 1, # mips, mipsel _fdata => 1, # mips, mipsel _fini => 1, # ALL _ftext => 1, # mips, mipsel _GLOBAL_OFFSET_TABLE_ => 1, # hppa, mips, mipsel __gmon_start__ => 1, # hppa __gnu_local_gp => 1, # mips, mipsel _gp => 1, # mips, mipsel _init => 1, # ALL _PROCEDURE_LINKAGE_TABLE_ => 1, # sparc, alpha _SDA2_BASE_ => 1, # powerpc _SDA_BASE_ => 1, # powerpc ); for my $i (14 .. 31) { # Many powerpc specific symbols $internal_symbol{"_restfpr_$i"} = 1; $internal_symbol{"_restfpr_$i\_x"} = 1; $internal_symbol{"_restgpr_$i"} = 1; $internal_symbol{"_restgpr_$i\_x"} = 1; $internal_symbol{"_savefpr_$i"} = 1; $internal_symbol{"_savegpr_$i"} = 1; } sub symbol_is_internal { my ($symbol, $include_groups) = @_; return 1 if exists $internal_symbol{$symbol}; # The ARM Embedded ABI spec states symbols under this namespace as # possibly appearing in output objects. return 1 if not ${$include_groups}{aeabi} and $symbol =~ /^__aeabi_/; # The GNU implementation of the OpenMP spec, specifies symbols under # this namespace as possibly appearing in output objects. return 1 if not ${$include_groups}{gomp} and $symbol =~ /^\.gomp_critical_user_/; return 0; } sub new { my ($this, %opts) = @_; my $class = ref($this) || $this; my $self = \%opts; bless $self, $class; $self->{arch} //= get_host_arch(); $self->clear(); if (exists $self->{file}) { $self->load($self->{file}) if -e $self->{file}; } return $self; } sub get_arch { my $self = shift; return $self->{arch}; } sub clear { my $self = shift; $self->{objects} = {}; } sub clear_except { my ($self, @ids) = @_; my %has = map { $_ => 1 } @ids; foreach my $objid (keys %{$self->{objects}}) { delete $self->{objects}{$objid} unless exists $has{$objid}; } } sub get_sonames { my $self = shift; return keys %{$self->{objects}}; } sub get_symbols { my ($self, $soname) = @_; if (defined $soname) { my $obj = $self->get_object($soname); return (defined $obj) ? values %{$obj->{syms}} : (); } else { my @syms; foreach my $soname ($self->get_sonames()) { push @syms, $self->get_symbols($soname); } return @syms; } } sub get_patterns { my ($self, $soname) = @_; my @patterns; if (defined $soname) { my $obj = $self->get_object($soname); foreach my $alias (values %{$obj->{patterns}{aliases}}) { push @patterns, values %$alias; } return (@patterns, @{$obj->{patterns}{generic}}); } else { foreach my $soname ($self->get_sonames()) { push @patterns, $self->get_patterns($soname); } return @patterns; } } # Create a symbol from the supplied string specification. sub create_symbol { my ($self, $spec, %opts) = @_; my $symbol = (exists $opts{base}) ? $opts{base} : Dpkg::Shlibs::Symbol->new(); my $ret = $opts{dummy} ? $symbol->parse_symbolspec($spec, default_minver => 0) : $symbol->parse_symbolspec($spec); if ($ret) { $symbol->initialize(arch => $self->get_arch()); return $symbol; } return; } sub add_symbol { my ($self, $symbol, $soname) = @_; my $object = $self->get_object($soname); if ($symbol->is_pattern()) { if (my $alias_type = $symbol->get_alias_type()) { $object->{patterns}{aliases}{$alias_type} //= {}; # Alias hash for matching. my $aliases = $object->{patterns}{aliases}{$alias_type}; $aliases->{$symbol->get_symbolname()} = $symbol; } else { # Otherwise assume this is a generic sequential pattern. This # should be always safe. push @{$object->{patterns}{generic}}, $symbol; } return 'pattern'; } else { # invalidate the minimum version cache $object->{minver_cache} = []; $object->{syms}{$symbol->get_symbolname()} = $symbol; return 'sym'; } } sub _new_symbol { my $base = shift || 'Dpkg::Shlibs::Symbol'; return (ref $base) ? $base->clone(@_) : $base->new(@_); } # Option state is only used for recursive calls. sub parse { my ($self, $fh, $file, %opts) = @_; my $state = $opts{state} //= {}; if (exists $state->{seen}) { return if exists $state->{seen}{$file}; # Avoid include loops } else { $self->{file} = $file; $state->{seen} = {}; } $state->{seen}{$file} = 1; if (not ref $state->{obj_ref}) { # Init ref to name of current object/lib ${$state->{obj_ref}} = undef; } while (<$fh>) { chomp; if (/^(?:\s+|#(?:DEPRECATED|MISSING): ([^#]+)#\s*)(.*)/) { if (not defined ${$state->{obj_ref}}) { error(g_('symbol information must be preceded by a header (file %s, line %s)'), $file, $.); } # Symbol specification 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}}); } else { warning(g_('failed to parse line in %s: %s'), $file, $_); } } elsif (/^(\(.*\))?#include\s+"([^"]+)"/) { my $tagspec = $1; my $filename = $2; my $dir = $file; my $old_base_symbol = $state->{base_symbol}; my $new_base_symbol; if (defined $tagspec) { $new_base_symbol = _new_symbol($old_base_symbol); $new_base_symbol->parse_tagspec($tagspec); } $state->{base_symbol} = $new_base_symbol; $dir =~ s{[^/]+$}{}; # Strip filename $self->load("$dir$filename", %opts); $state->{base_symbol} = $old_base_symbol; } elsif (/^#|^$/) { # Skip possible comments and empty lines } elsif (/^\|\s*(.*)$/) { # Alternative dependency template push @{$self->{objects}{${$state->{obj_ref}}}{deps}}, "$1"; } elsif (/^\*\s*([^:]+):\s*(.*\S)\s*$/) { # Add meta-fields $self->{objects}{${$state->{obj_ref}}}{fields}{field_capitalize($1)} = $2; } elsif (/^(\S+)\s+(.*)$/) { # New object and dependency template ${$state->{obj_ref}} = $1; if (exists $self->{objects}{${$state->{obj_ref}}}) { # Update/override infos only $self->{objects}{${$state->{obj_ref}}}{deps} = [ "$2" ]; } else { # Create a new object $self->create_object(${$state->{obj_ref}}, "$2"); } } else { warning(g_('failed to parse a line in %s: %s'), $file, $_); } } delete $state->{seen}{$file}; } # Beware: we reuse the data structure of the provided symfile so make # sure to not modify them after having called this function sub merge_object_from_symfile { my ($self, $src, $objid) = @_; if (not $self->has_object($objid)) { $self->{objects}{$objid} = $src->get_object($objid); } else { warning(g_('tried to merge the same object (%s) twice in a symfile'), $objid); } } sub output { my ($self, $fh, %opts) = @_; $opts{template_mode} //= 0; $opts{with_deprecated} //= 1; $opts{with_pattern_matches} //= 0; my $res = ''; foreach my $soname (sort $self->get_sonames()) { my @deps = $self->get_dependencies($soname); my $dep_first = shift @deps; if (exists $opts{package} and not $opts{template_mode}) { $dep_first =~ s/#PACKAGE#/$opts{package}/g; } print { $fh } "$soname $dep_first\n" if defined $fh; $res .= "$soname $dep_first\n" if defined wantarray; foreach my $dep_next (@deps) { if (exists $opts{package} and not $opts{template_mode}) { $dep_next =~ s/#PACKAGE#/$opts{package}/g; } print { $fh } "| $dep_next\n" if defined $fh; $res .= "| $dep_next\n" if defined wantarray; } my $f = $self->{objects}{$soname}{fields}; foreach my $field (sort keys %{$f}) { my $value = $f->{$field}; if (exists $opts{package} and not $opts{template_mode}) { $value =~ s/#PACKAGE#/$opts{package}/g; } print { $fh } "* $field: $value\n" if defined $fh; $res .= "* $field: $value\n" if defined wantarray; } my @symbols; if ($opts{template_mode}) { # Exclude symbols matching a pattern, but include patterns themselves @symbols = grep { not $_->get_pattern() } $self->get_symbols($soname); push @symbols, $self->get_patterns($soname); } else { @symbols = $self->get_symbols($soname); } foreach my $sym (sort { $a->get_symboltempl() cmp $b->get_symboltempl() } @symbols) { next if $sym->{deprecated} and not $opts{with_deprecated}; # Do not dump symbols from foreign arch unless dumping a template. next if not $opts{template_mode} and not $sym->arch_is_concerned($self->get_arch()); # Dump symbol specification. Dump symbol tags only in template mode. print { $fh } $sym->get_symbolspec($opts{template_mode}), "\n" if defined $fh; $res .= $sym->get_symbolspec($opts{template_mode}) . "\n" if defined wantarray; # Dump pattern matches as comments (if requested) if ($opts{with_pattern_matches} && $sym->is_pattern()) { for my $match (sort { $a->get_symboltempl() cmp $b->get_symboltempl() } $sym->get_pattern_matches()) { print { $fh } '#MATCH:', $match->get_symbolspec(0), "\n" if defined $fh; $res .= '#MATCH:' . $match->get_symbolspec(0) . "\n" if defined wantarray; } } } } return $res; } # Tries to match a symbol name and/or version against the patterns defined. # Returns a pattern which matches (if any). sub find_matching_pattern { my ($self, $refsym, $sonames, $inc_deprecated) = @_; $inc_deprecated //= 0; my $name = (ref $refsym) ? $refsym->get_symbolname() : $refsym; my $pattern_ok = sub { my $p = shift; return defined $p && ($inc_deprecated || !$p->{deprecated}) && $p->arch_is_concerned($self->get_arch()); }; foreach my $soname ((ref($sonames) eq 'ARRAY') ? @$sonames : $sonames) { my $obj = $self->get_object($soname); my ($type, $pattern); next unless defined $obj; my $all_aliases = $obj->{patterns}{aliases}; for my $type (Dpkg::Shlibs::Symbol::ALIAS_TYPES) { if (exists $all_aliases->{$type} && keys(%{$all_aliases->{$type}})) { my $aliases = $all_aliases->{$type}; my $converter = $aliases->{(keys %$aliases)[0]}; if (my $alias = $converter->convert_to_alias($name)) { if ($alias && exists $aliases->{$alias}) { $pattern = $aliases->{$alias}; last if $pattern_ok->($pattern); $pattern = undef; # otherwise not found yet } } } } # Now try generic patterns and use the first that matches if (not defined $pattern) { for my $p (@{$obj->{patterns}{generic}}) { if ($pattern_ok->($p) && $p->matches_rawname($name)) { $pattern = $p; last; } } } if (defined $pattern) { return (wantarray) ? ( symbol => $pattern, soname => $soname ) : $pattern; } } return; } # merge_symbols($object, $minver) # Needs $Objdump->get_object($soname) as parameter # Do not merge symbols found in the list of (arch-specific) internal symbols. sub merge_symbols { my ($self, $object, $minver) = @_; my $soname = $object->{SONAME}; error(g_('cannot merge symbols from objects without SONAME')) unless $soname; my %include_groups = (); my $groups = $self->get_field($soname, 'Allow-Internal-Symbol-Groups'); if (not defined $groups) { $groups = $self->get_field($soname, 'Ignore-Blacklist-Groups'); if (defined $groups) { warnings::warnif('deprecated', 'symbols file field "Ignore-Blacklist-Groups" is deprecated, ' . 'use "Allow-Internal-Symbol-Groups" instead'); } } if (defined $groups) { $include_groups{$_} = 1 foreach (split ' ', $groups); } my %dynsyms; foreach my $sym ($object->get_exported_dynamic_symbols()) { my $name = $sym->{name} . '@' . ($sym->{version} ? $sym->{version} : 'Base'); my $symobj = $self->lookup_symbol($name, $soname); if (symbol_is_internal($sym->{name}, \%include_groups)) { next unless defined $symobj; if ($symobj->has_tag('allow-internal')) { # Allow the symbol. } elsif ($symobj->has_tag('ignore-blacklist')) { # Allow the symbol and warn. warnings::warnif('deprecated', 'symbol tag "ignore-blacklist" is deprecated, ' . 'use "allow-internal" instead'); } else { # Ignore the symbol. next; } } $dynsyms{$name} = $sym; } unless ($self->has_object($soname)) { $self->create_object($soname, ''); } # Scan all symbols provided by the objects my $obj = $self->get_object($soname); # invalidate the minimum version cache - it is not sufficient to # invalidate in add_symbol, since we might change a minimum # version for a particular symbol without adding it $obj->{minver_cache} = []; foreach my $name (keys %dynsyms) { my $sym; if ($sym = $self->lookup_symbol($name, $obj, 1)) { # If the symbol is already listed in the file $sym->mark_found_in_library($minver, $self->get_arch()); } else { # The exact symbol is not present in the file, but it might match a # pattern. my $pattern = $self->find_matching_pattern($name, $obj, 1); if (defined $pattern) { $pattern->mark_found_in_library($minver, $self->get_arch()); $sym = $pattern->create_pattern_match(symbol => $name); } else { # Symbol without any special info as no pattern matched $sym = Dpkg::Shlibs::Symbol->new(symbol => $name, minver => $minver); } $self->add_symbol($sym, $obj); } } # Process all symbols which could not be found in the library. foreach my $sym ($self->get_symbols($soname)) { if (not exists $dynsyms{$sym->get_symbolname()}) { $sym->mark_not_found_in_library($minver, $self->get_arch()); } } # Deprecate patterns which didn't match anything for my $pattern (grep { $_->get_pattern_matches() == 0 } $self->get_patterns($soname)) { $pattern->mark_not_found_in_library($minver, $self->get_arch()); } } sub is_empty { my $self = shift; return scalar(keys %{$self->{objects}}) ? 0 : 1; } sub has_object { my ($self, $soname) = @_; return exists $self->{objects}{$soname}; } sub get_object { my ($self, $soname) = @_; return ref($soname) ? $soname : $self->{objects}{$soname}; } sub create_object { my ($self, $soname, @deps) = @_; $self->{objects}{$soname} = { syms => {}, fields => {}, patterns => { aliases => {}, generic => [], }, deps => [ @deps ], minver_cache => [] }; } sub get_dependency { my ($self, $soname, $dep_id) = @_; $dep_id //= 0; return $self->get_object($soname)->{deps}[$dep_id]; } sub get_smallest_version { my ($self, $soname, $dep_id) = @_; $dep_id //= 0; my $so_object = $self->get_object($soname); return $so_object->{minver_cache}[$dep_id] if defined $so_object->{minver_cache}[$dep_id]; my $minver; foreach my $sym ($self->get_symbols($so_object)) { next if $dep_id != $sym->{dep_id}; $minver //= $sym->{minver}; if (version_compare($minver, $sym->{minver}) > 0) { $minver = $sym->{minver}; } } $so_object->{minver_cache}[$dep_id] = $minver; return $minver; } sub get_dependencies { my ($self, $soname) = @_; return @{$self->get_object($soname)->{deps}}; } sub get_field { my ($self, $soname, $name) = @_; if (my $obj = $self->get_object($soname)) { if (exists $obj->{fields}{$name}) { return $obj->{fields}{$name}; } } return; } # Tries to find a symbol like the $refsym and returns its descriptor. # $refsym may also be a symbol name. sub lookup_symbol { my ($self, $refsym, $sonames, $inc_deprecated) = @_; $inc_deprecated //= 0; my $name = (ref $refsym) ? $refsym->get_symbolname() : $refsym; foreach my $so ((ref($sonames) eq 'ARRAY') ? @$sonames : $sonames) { if (my $obj = $self->get_object($so)) { my $sym = $obj->{syms}{$name}; if ($sym and ($inc_deprecated or not $sym->{deprecated})) { return (wantarray) ? ( symbol => $sym, soname => $so ) : $sym; } } } return; } # Tries to find a pattern like the $refpat and returns its descriptor. # $refpat may also be a pattern spec. sub lookup_pattern { my ($self, $refpat, $sonames, $inc_deprecated) = @_; $inc_deprecated //= 0; # If $refsym is a string, we need to create a dummy ref symbol. $refpat = $self->create_symbol($refpat, dummy => 1) if ! ref($refpat); if ($refpat && $refpat->is_pattern()) { foreach my $soname ((ref($sonames) eq 'ARRAY') ? @$sonames : $sonames) { if (my $obj = $self->get_object($soname)) { my $pat; if (my $type = $refpat->get_alias_type()) { if (exists $obj->{patterns}{aliases}{$type}) { $pat = $obj->{patterns}{aliases}{$type}{$refpat->get_symbolname()}; } } elsif ($refpat->get_pattern_type() eq 'generic') { for my $p (@{$obj->{patterns}{generic}}) { if (($inc_deprecated || !$p->{deprecated}) && $p->equals($refpat, versioning => 0)) { $pat = $p; last; } } } if ($pat && ($inc_deprecated || !$pat->{deprecated})) { return (wantarray) ? (symbol => $pat, soname => $soname) : $pat; } } } } return; } # Get symbol object reference either by symbol name or by a reference object. sub get_symbol_object { my ($self, $refsym, $soname) = @_; my $sym = $self->lookup_symbol($refsym, $soname, 1); if (! defined $sym) { $sym = $self->lookup_pattern($refsym, $soname, 1); } return $sym; } sub get_new_symbols { my ($self, $ref, %opts) = @_; my $with_optional = (exists $opts{with_optional}) ? $opts{with_optional} : 0; my @res; foreach my $soname ($self->get_sonames()) { next if not $ref->has_object($soname); # Scan raw symbols first. foreach my $sym (grep { ($with_optional || ! $_->is_optional()) && $_->is_legitimate($self->get_arch()) } $self->get_symbols($soname)) { my $refsym = $ref->lookup_symbol($sym, $soname, 1); my $isnew; if (defined $refsym) { # If the symbol exists in the $ref symbol file, it might # still be new if $refsym is not legitimate. $isnew = not $refsym->is_legitimate($self->get_arch()); } else { # If the symbol does not exist in the $ref symbol file, it does # not mean that it's new. It might still match a pattern in the # symbol file. However, due to performance reasons, first check # if the pattern that the symbol matches (if any) exists in the # ref symbol file as well. $isnew = not ( ($sym->get_pattern() and $ref->lookup_pattern($sym->get_pattern(), $soname, 1)) or $ref->find_matching_pattern($sym, $soname, 1) ); } push @res, { symbol => $sym, soname => $soname } if $isnew; } # Now scan patterns foreach my $p (grep { ($with_optional || ! $_->is_optional()) && $_->is_legitimate($self->get_arch()) } $self->get_patterns($soname)) { my $refpat = $ref->lookup_pattern($p, $soname, 0); # If reference pattern was not found or it is not legitimate, # considering current one as new. if (not defined $refpat or not $refpat->is_legitimate($self->get_arch())) { push @res, { symbol => $p , soname => $soname }; } } } return @res; } sub get_lost_symbols { my ($self, $ref, %opts) = @_; return $ref->get_new_symbols($self, %opts); } sub get_new_libs { my ($self, $ref) = @_; my @res; foreach my $soname ($self->get_sonames()) { push @res, $soname if not $ref->get_object($soname); } return @res; } sub get_lost_libs { my ($self, $ref) = @_; return $ref->get_new_libs($self); } 1; PK ! �l��� � Shlibs/Cppfilt.pmnu �[��� # Copyright © 2009-2010 Modestas Vainius <modax@debian.org> # Copyright © 2010, 2012-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::Shlibs::Cppfilt; use strict; use warnings; our $VERSION = '0.01'; our @EXPORT = qw( cppfilt_demangle_cpp ); our @EXPORT_OK = qw( cppfilt_demangle ); use Exporter qw(import); use Dpkg::ErrorHandling; use Dpkg::IPC; # A hash of 'objects' referring to preforked c++filt processes for the distinct # demangling types. my %cppfilts; sub get_cppfilt { my $type = shift || 'auto'; # Fork c++filt process for demangling $type unless it is forked already. # Keeping c++filt running improves performance a lot. my $filt; if (exists $cppfilts{$type}) { $filt = $cppfilts{$type}; } else { $filt = { from => undef, to => undef, last_symbol => '', last_result => '' }; $filt->{pid} = spawn(exec => [ 'c++filt', "--format=$type" ], from_pipe => \$filt->{from}, to_pipe => \$filt->{to}); syserr(g_('unable to execute %s'), 'c++filt') unless defined $filt->{from}; $filt->{from}->autoflush(1); $cppfilts{$type} = $filt; } return $filt; } # Demangle the given $symbol using demangler for the specified $type (defaults # to 'auto') . Extraneous characters trailing after a mangled name are kept # intact. If neither whole $symbol nor portion of it could be demangled, undef # is returned. sub cppfilt_demangle { my ($symbol, $type) = @_; # Start or get c++filt 'object' for the requested type. my $filt = get_cppfilt($type); # Remember the last result. Such a local optimization is cheap and useful # when sequential pattern matching is performed. if ($filt->{last_symbol} ne $symbol) { # This write/read operation should not deadlock because c++filt flushes # output buffer on LF or each invalid character. print { $filt->{from} } $symbol, "\n"; my $demangled = readline($filt->{to}); chop $demangled; # If the symbol was not demangled, return undef $demangled = undef if $symbol eq $demangled; # Remember the last result $filt->{last_symbol} = $symbol; $filt->{last_result} = $demangled; } return $filt->{last_result}; } sub cppfilt_demangle_cpp { my $symbol = shift; return cppfilt_demangle($symbol, 'auto'); } sub terminate_cppfilts { foreach my $type (keys %cppfilts) { next if not defined $cppfilts{$type}{pid}; close $cppfilts{$type}{from}; close $cppfilts{$type}{to}; wait_child($cppfilts{$type}{pid}, cmdline => 'c++filt', nocheck => 1, timeout => 5); delete $cppfilts{$type}; } } # Close/terminate running c++filt process(es) END { # Make sure exitcode is not changed (by wait_child) my $exitcode = $?; terminate_cppfilts(); $? = $exitcode; } 1; PK ! �'e-�D �D Shlibs/Objdump.pmnu �[��� # 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 # 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::Shlibs::Objdump; use strict; use warnings; use feature qw(state); our $VERSION = '0.01'; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::IPC; sub new { my $this = shift; my $class = ref($this) || $this; my $self = { objects => {} }; bless $self, $class; return $self; } sub add_object { my ($self, $obj) = @_; my $id = $obj->get_id; if ($id) { $self->{objects}{$id} = $obj; } return $id; } sub analyze { my ($self, $file) = @_; my $obj = Dpkg::Shlibs::Objdump::Object->new($file); return $self->add_object($obj); } sub locate_symbol { my ($self, $name) = @_; foreach my $obj (values %{$self->{objects}}) { my $sym = $obj->get_symbol($name); if (defined($sym) && $sym->{defined}) { return $sym; } } return; } sub get_object { my ($self, $objid) = @_; if ($self->has_object($objid)) { return $self->{objects}{$objid}; } return; } sub has_object { my ($self, $objid) = @_; return exists $self->{objects}{$objid}; } sub is_armhf { my ($file) = @_; my ($output, %opts, $pid, $res); my $hf = 0; my $sf = 0; $pid = spawn(exec => [ "readelf", "-h", "--", $file ], env => { "LC_ALL" => "C" }, to_pipe => \$output, %opts); while (<$output>) { chomp; if (/0x500040./) { $hf = 1; last; } if (/0x500020./) { $sf = 1; last; } } close($output); wait_child($pid, nocheck => 1); if ($?) { subprocerr("readelf"); } if(($hf) || ($sf)) { return $hf; } $hf = 0; undef $output; $pid = spawn(exec => [ "readelf", "-A", "--", $file ], env => { "LC_ALL" => "C" }, to_pipe => \$output, %opts); while (<$output>) { chomp; if (/Tag_ABI_VFP_args: VFP registers/) { $hf = 1; last; } } close($output); wait_child($pid, nocheck => 1); if ($?) { subprocerr("readelf"); } return $hf; } use constant { ELF_BITS_NONE => 0, ELF_BITS_32 => 1, ELF_BITS_64 => 2, ELF_ORDER_NONE => 0, ELF_ORDER_2LSB => 1, ELF_ORDER_2MSB => 2, ELF_MACH_SPARC => 2, ELF_MACH_MIPS => 8, ELF_MACH_SPARC64_OLD => 11, ELF_MACH_SPARC32PLUS => 18, ELF_MACH_PPC64 => 21, ELF_MACH_S390 => 22, ELF_MACH_ARM => 40, ELF_MACH_ALPHA_OLD => 41, ELF_MACH_SH => 42, ELF_MACH_SPARC64 => 43, ELF_MACH_IA64 => 50, ELF_MACH_AVR => 83, ELF_MACH_M32R => 88, ELF_MACH_MN10300 => 89, ELF_MACH_MN10200 => 90, ELF_MACH_OR1K => 92, ELF_MACH_XTENSA => 94, ELF_MACH_MICROBLAZE => 189, ELF_MACH_ARCV2 => 195, ELF_MACH_AVR_OLD => 0x1057, ELF_MACH_OR1K_OLD => 0x8472, ELF_MACH_ALPHA => 0x9026, ELF_MACH_M32R_CYGNUS => 0x9041, ELF_MACH_S390_OLD => 0xa390, ELF_MACH_XTENSA_OLD => 0xabc7, ELF_MACH_MICROBLAZE_OLD => 0xbaab, ELF_MACH_MN10300_CYGNUS => 0xbeef, ELF_MACH_MN10200_CYGNUS => 0xdead, ELF_VERSION_NONE => 0, ELF_VERSION_CURRENT => 1, # List of processor flags that might influence the ABI. ELF_FLAG_ARM_ALIGN8 => 0x00000040, ELF_FLAG_ARM_NEW_ABI => 0x00000080, ELF_FLAG_ARM_OLD_ABI => 0x00000100, ELF_FLAG_ARM_SOFT_FLOAT => 0x00000200, ELF_FLAG_ARM_HARD_FLOAT => 0x00000400, ELF_FLAG_ARM_EABI_MASK => 0xff000000, ELF_FLAG_IA64_ABI64 => 0x00000010, ELF_FLAG_MIPS_ABI2 => 0x00000020, ELF_FLAG_MIPS_32BIT => 0x00000100, ELF_FLAG_MIPS_FP64 => 0x00000200, ELF_FLAG_MIPS_NAN2008 => 0x00000400, ELF_FLAG_MIPS_ABI_MASK => 0x0000f000, ELF_FLAG_MIPS_ARCH_MASK => 0xf0000000, ELF_FLAG_PPC64_ABI64 => 0x00000003, ELF_FLAG_SH_MACH_MASK => 0x0000001f, }; # These map alternative or old machine IDs to their canonical form. my %elf_mach_map = ( ELF_MACH_ALPHA_OLD() => ELF_MACH_ALPHA, ELF_MACH_AVR_OLD() => ELF_MACH_AVR, ELF_MACH_M32R_CYGNUS() => ELF_MACH_M32R, ELF_MACH_MICROBLAZE_OLD() => ELF_MACH_MICROBLAZE, ELF_MACH_MN10200_CYGNUS() => ELF_MACH_MN10200, ELF_MACH_MN10300_CYGNUS() => ELF_MACH_MN10300, ELF_MACH_OR1K_OLD() => ELF_MACH_OR1K, ELF_MACH_S390_OLD() => ELF_MACH_S390, ELF_MACH_SPARC32PLUS() => ELF_MACH_SPARC, ELF_MACH_SPARC64_OLD() => ELF_MACH_SPARC64, ELF_MACH_XTENSA_OLD() => ELF_MACH_XTENSA, ); # These masks will try to expose processor flags that are ABI incompatible, # and as such are part of defining the architecture ABI. If uncertain it is # always better to not mask a flag, because that preserves the historical # behavior, and we do not drop dependencies. my %elf_flags_mask = ( ELF_MACH_IA64() => ELF_FLAG_IA64_ABI64, ELF_MACH_MIPS() => ELF_FLAG_MIPS_ABI_MASK | ELF_FLAG_MIPS_ABI2, ELF_MACH_PPC64() => ELF_FLAG_PPC64_ABI64, ); sub get_format { my ($file) = @_; state %format; return $format{$file} if exists $format{$file}; my $header; open my $fh, '<', $file or syserr(g_('cannot read %s'), $file); my $rc = read $fh, $header, 64; if (not defined $rc) { syserr(g_('cannot read %s'), $file); } elsif ($rc != 64) { return; } close $fh; my %elf; # Unpack the identifier field. @elf{qw(magic bits endian vertype osabi verabi)} = unpack 'a4C5', $header; return unless $elf{magic} eq "\x7fELF"; return unless $elf{vertype} == ELF_VERSION_CURRENT; my ($elf_word, $elf_endian); if ($elf{bits} == ELF_BITS_32) { $elf_word = 'L'; } elsif ($elf{bits} == ELF_BITS_64) { $elf_word = 'Q'; } else { return; } if ($elf{endian} == ELF_ORDER_2LSB) { $elf_endian = '<'; } elsif ($elf{endian} == ELF_ORDER_2MSB) { $elf_endian = '>'; } else { return; } # Unpack the endianness and size dependent fields. my $tmpl = "x16(S2Lx[${elf_word}3]L)${elf_endian}"; @elf{qw(type mach version flags)} = unpack $tmpl, $header; # Canonicalize the machine ID. $elf{mach} = $elf_mach_map{$elf{mach}} // $elf{mach}; # Mask any processor flags that might not change the architecture ABI. $elf{flags} &= $elf_flags_mask{$elf{mach}} // 0; if (($elf{mach} == ELF_MACH_ARM) && ($elf{endian} == ELF_ORDER_2LSB)) { if (is_armhf($file)) { $elf{flags} |= ELF_FLAG_ARM_HARD_FLOAT; } else { $elf{flags} |= ELF_FLAG_ARM_SOFT_FLOAT; } } # Repack for easy comparison, as a big-endian byte stream, so that # unpacking for output gives meaningful results. $format{$file} = pack 'C2(SL)>', @elf{qw(bits endian mach flags)}; return $format{$file}; } sub is_elf { my $file = shift; open(my $file_fh, '<', $file) or syserr(g_('cannot read %s'), $file); my ($header, $result) = ('', 0); if (read($file_fh, $header, 4) == 4) { $result = 1 if ($header =~ /^\177ELF$/); } close($file_fh); return $result; } 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; my $file = shift // ''; my $class = ref($this) || $this; my $self = {}; bless $self, $class; $self->reset; if ($file) { $self->analyze($file); } return $self; } sub reset { my $self = shift; $self->{file} = ''; $self->{id} = ''; $self->{HASH} = ''; $self->{GNU_HASH} = ''; $self->{INTERP} = 0; $self->{SONAME} = ''; $self->{NEEDED} = []; $self->{RPATH} = []; $self->{dynsyms} = {}; $self->{flags} = {}; $self->{dynrelocs} = {}; 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) = @_; $file ||= $self->{file}; return unless $file; $self->reset; $self->{file} = $file; $self->{exec_abi} = Dpkg::Shlibs::Objdump::get_format($file); if (not defined $self->{exec_abi}) { warning(g_("unknown executable format in file '%s'"), $file); 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); my $ret = $self->parse_objdump_output($objdump); close($objdump); return $ret; } sub parse_objdump_output { my ($self, $fh) = @_; my $section = 'none'; while (<$fh>) { s/\s*$//; next if length == 0; if (/^DYNAMIC SYMBOL TABLE:/) { $section = 'dynsym'; next; } elsif (/^DYNAMIC RELOCATION RECORDS/) { $section = 'dynreloc'; $_ = <$fh>; # Skip header next; } elsif (/^Dynamic Section:/) { $section = 'dyninfo'; next; } elsif (/^Program Header:/) { $section = 'program'; next; } elsif (/^Version definitions:/) { $section = 'verdef'; next; } elsif (/^Version References:/) { $section = 'verref'; next; } if ($section eq 'dynsym') { $self->parse_dynamic_symbol($_); } elsif ($section eq 'dynreloc') { if (/^\S+\s+(\S+)\s+(.+)$/) { $self->{dynrelocs}{$2} = $1; } else { warning(g_("couldn't parse dynamic relocation record: %s"), $_); } } elsif ($section eq 'dyninfo') { if (/^\s*NEEDED\s+(\S+)/) { push @{$self->{NEEDED}}, $1; } elsif (/^\s*SONAME\s+(\S+)/) { $self->{SONAME} = $1; } elsif (/^\s*HASH\s+(\S+)/) { $self->{HASH} = $1; } elsif (/^\s*GNU_HASH\s+(\S+)/) { $self->{GNU_HASH} = $1; } elsif (/^\s*RUNPATH\s+(\S+)/) { # RUNPATH takes precedence over RPATH but is # considered after LD_LIBRARY_PATH while RPATH # is considered before (if RUNPATH is not set). my $runpath = $1; $self->{RPATH} = [ split /:/, $runpath ]; } elsif (/^\s*RPATH\s+(\S+)/) { my $rpath = $1; unless (scalar(@{$self->{RPATH}})) { $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; if (($self->{format} eq "elf32-littlearm") && $self->{file}) { if (Dpkg::Shlibs::Objdump::is_armhf($self->{file})) { $self->{format} = "elf32-littlearm-hfabi"; } else { $self->{format} = "elf32-littlearm-sfabi"; } } } elsif (/^architecture:\s*\S+,\s*flags\s*\S+:$/) { # Parse 2 lines of "-f" # architecture: i386, flags 0x00000112: # EXEC_P, HAS_SYMS, D_PAGED # start address 0x08049b50 $_ = <$fh>; chomp; $self->{flags}{$_} = 1 foreach (split(/,\s*/)); } } } # Update status of dynamic symbols given the relocations that have # been parsed after the symbols... $self->apply_relocations(); return $section ne 'none'; } # Output format of objdump -w -T # # /lib/libc.so.6: file format elf32-i386 # # DYNAMIC SYMBOL TABLE: # 00056ef0 g DF .text 000000db GLIBC_2.2 getwchar # 00000000 g DO *ABS* 00000000 GCC_3.0 GCC_3.0 # 00069960 w DF .text 0000001e GLIBC_2.0 bcmp # 00000000 w D *UND* 00000000 _pthread_cleanup_pop_restore # 0000b788 g DF .text 0000008e Base .protected xine_close # 0000b788 g DF .text 0000008e .hidden IA__g_free # | ||||||| | | | | # | ||||||| | | Version str (.visibility) + Symbol name # | ||||||| | Alignment # | ||||||| Section name (or *UND* for an undefined symbol) # | ||||||F=Function,f=file,O=object # | |||||d=debugging,D=dynamic # | ||||I=Indirect # | |||W=warning # | ||C=constructor # | |w=weak # | g=global,l=local,!=both global/local # Size of the symbol # # GLIBC_2.2 is the version string associated to the symbol # (GLIBC_2.2) is the same but the symbol is hidden, a newer version of the # symbol exist my $vis_re = qr/(\.protected|\.hidden|\.internal|0x\S+)/; my $dynsym_re = qr< ^ [0-9a-f]+ # Symbol size \ (.{7}) # Flags \s+(\S+) # Section name \s+[0-9a-f]+ # Alignment (?:\s+(\S+))? # Version string (?:\s+$vis_re)? # Visibility \s+(.+) # Symbol name >x; sub parse_dynamic_symbol { my ($self, $line) = @_; if ($line =~ $dynsym_re) { my ($flags, $sect, $ver, $vis, $name) = ($1, $2, $3, $4, $5); # Special case if version is missing but extra visibility # attribute replaces it in the match if (defined($ver) and $ver =~ /^$vis_re$/) { $vis = $ver; $ver = ''; } # Cleanup visibility field $vis =~ s/^\.// if defined($vis); my $symbol = { name => $name, version => $ver // '', section => $sect, dynamic => substr($flags, 5, 1) eq 'D', debug => substr($flags, 5, 1) eq 'd', type => substr($flags, 6, 1), weak => substr($flags, 1, 1) eq 'w', local => substr($flags, 0, 1) eq 'l', global => substr($flags, 0, 1) eq 'g', visibility => $vis // '', hidden => '', defined => $sect ne '*UND*' }; # Handle hidden symbols if (defined($ver) and $ver =~ /^\((.*)\)$/) { $ver = $1; $symbol->{version} = $1; $symbol->{hidden} = 1; } # Register symbol $self->add_dynamic_symbol($symbol); } elsif ($line =~ /^[0-9a-f]+ (.{7})\s+(\S+)\s+[0-9a-f]+/) { # Same start but no version and no symbol ... just ignore } elsif ($line =~ /^REG_G\d+\s+/) { # Ignore some s390-specific output like # REG_G6 g R *UND* 0000000000000000 #scratch } else { warning(g_("couldn't parse dynamic symbol definition: %s"), $line); } } sub apply_relocations { my $self = shift; foreach my $sym (values %{$self->{dynsyms}}) { # We want to mark as undefined symbols those which are currently # defined but that depend on a copy relocation next if not $sym->{defined}; my @relocs; # When objdump qualifies the symbol with a version it will use @ when # the symbol is in an undefined section (which we discarded above, or # @@ otherwise. push @relocs, $sym->{name} . '@@' . $sym->{version} if $sym->{version}; # Symbols that are not versioned, or versioned but shown with objdump # fopm binutils < 2.26, do not have a version appended. push @relocs, $sym->{name}; foreach my $reloc (@relocs) { next if not exists $self->{dynrelocs}{$reloc}; next if not $self->{dynrelocs}{$reloc} =~ /^R_.*_COPY$/; $sym->{defined} = 0; last; } } } sub add_dynamic_symbol { my ($self, $symbol) = @_; $symbol->{objid} = $symbol->{soname} = $self->get_id(); $symbol->{soname} =~ s{^.*/}{} unless $self->{SONAME}; if ($symbol->{version}) { $self->{dynsyms}{$symbol->{name} . '@' . $symbol->{version}} = $symbol; } else { $self->{dynsyms}{$symbol->{name} . '@Base'} = $symbol; } } sub get_id { my $self = shift; return $self->{SONAME} || $self->{file}; } sub get_symbol { my ($self, $name) = @_; if (exists $self->{dynsyms}{$name}) { return $self->{dynsyms}{$name}; } if ($name !~ /@/) { if (exists $self->{dynsyms}{$name . '@Base'}) { return $self->{dynsyms}{$name . '@Base'}; } } return; } sub get_exported_dynamic_symbols { my $self = shift; return grep { $_->{defined} && $_->{dynamic} && !$_->{local} } values %{$self->{dynsyms}}; } sub get_undefined_dynamic_symbols { my $self = shift; return grep { (!$_->{defined}) && $_->{dynamic} } values %{$self->{dynsyms}}; } sub get_needed_libraries { my $self = shift; return @{$self->{NEEDED}}; } sub is_executable { my $self = shift; return (exists $self->{flags}{EXEC_P} && $self->{flags}{EXEC_P}) || (exists $self->{INTERP} && $self->{INTERP}); } sub is_public_library { my $self = shift; return exists $self->{flags}{DYNAMIC} && $self->{flags}{DYNAMIC} && exists $self->{SONAME} && $self->{SONAME}; } 1; PK ! �=C�C7 C7 Shlibs/Symbol.pmnu �[��� # Copyright © 2007 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2009-2010 Modestas Vainius <modax@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::Shlibs::Symbol; use strict; use warnings; our $VERSION = '0.01'; use Storable (); use List::Util qw(any); use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Arch qw(debarch_is_concerned debarch_to_abiattrs); use Dpkg::Version; 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; my $self = bless { symbol => undef, symbol_templ => undef, minver => undef, dep_id => 0, deprecated => 0, tags => {}, tagorder => [], }, $class; $self->{$_} = $args{$_} foreach keys %args; return $self; } # Deep clone sub clone { my ($self, %args) = @_; my $clone = Storable::dclone($self); $clone->{$_} = $args{$_} foreach keys %args; return $clone; } sub parse_tagspec { my ($self, $tagspec) = @_; if ($tagspec =~ /^\s*\((.*?)\)(.*)$/ && $1) { # (tag1=t1 value|tag2|...|tagN=tNp) # Symbols ()|= cannot appear in the tag names and values my $tagspec = $1; my $rest = ($2) ? $2 : ''; my @tags = split(/\|/, $tagspec); # Parse each tag for my $tag (@tags) { if ($tag =~ /^(.*)=(.*)$/) { # Tag with value $self->add_tag($1, $2); } else { # Tag without value $self->add_tag($tag, undef); } } return $rest; } return; } sub parse_symbolspec { my ($self, $symbolspec, %opts) = @_; my $symbol; my $symbol_templ; my $symbol_quoted; my $rest; if (defined($symbol = $self->parse_tagspec($symbolspec))) { # (tag1=t1 value|tag2|...|tagN=tNp)"Foo::Bar::foobar()"@Base 1.0 1 # Symbols ()|= cannot appear in the tag names and values # If the tag specification exists symbol name template might be quoted too if ($symbol =~ /^(['"])/ && $symbol =~ /^($1)(.*?)$1(.*)$/) { $symbol_quoted = $1; $symbol_templ = $2; $symbol = $2; $rest = $3; } else { if ($symbol =~ m/^(\S+)(.*)$/) { $symbol_templ = $1; $symbol = $1; $rest = $2; } } error(g_('symbol name unspecified: %s'), $symbolspec) if (!$symbol); } else { # No tag specification. Symbol name is up to the first space # foobarsymbol@Base 1.0 1 if ($symbolspec =~ m/^(\S+)(.*)$/) { $symbol = $1; $rest = $2; } else { return 0; } } $self->{symbol} = $symbol; $self->{symbol_templ} = $symbol_templ; $self->{symbol_quoted} = $symbol_quoted if ($symbol_quoted); # Now parse "the rest" (minver and dep_id) if ($rest =~ /^\s(\S+)(?:\s(\d+))?/) { $self->{minver} = $1; $self->{dep_id} = $2 // 0; } elsif (defined $opts{default_minver}) { $self->{minver} = $opts{default_minver}; $self->{dep_id} = 0; } else { return 0; } return 1; } # A hook for symbol initialization (typically processing of tags). The code # here may even change symbol name. Called from # Dpkg::Shlibs::SymbolFile::create_symbol(). sub initialize { my $self = shift; # Look for tags marking symbol patterns. The pattern may match multiple # real symbols. my $type; if ($self->has_tag('c++')) { # Raw symbol name is always demangled to the same alias while demangled # symbol name cannot be reliably converted back to raw symbol name. # Therefore, we can use hash for mapping. $type = 'alias-c++'; } # Support old style wildcard syntax. That's basically a symver # with an optional tag. if ($self->get_symbolname() =~ /^\*@(.*)$/) { $self->add_tag('symver') unless $self->has_tag('symver'); $self->add_tag('optional') unless $self->has_tag('optional'); $self->{symbol} = $1; } if ($self->has_tag('symver')) { # Each symbol is matched against its version rather than full # name@version string. $type = (defined $type) ? 'generic' : 'alias-symver'; if ($self->get_symbolname() =~ /@/) { warning(g_('symver tag with versioned symbol will not match: %s'), $self->get_symbolspec(1)); } if ($self->get_symbolname() eq 'Base') { error(g_("you can't use symver tag to catch unversioned symbols: %s"), $self->get_symbolspec(1)); } } # As soon as regex is involved, we need to match each real # symbol against each pattern (aka 'generic' pattern). if ($self->has_tag('regex')) { $type = 'generic'; # Pre-compile regular expression for better performance. my $regex = $self->get_symbolname(); $self->{pattern}{regex} = qr/$regex/; } if (defined $type) { $self->init_pattern($type); } } sub get_symbolname { my $self = shift; return $self->{symbol}; } sub get_symboltempl { my $self = shift; return $self->{symbol_templ} || $self->{symbol}; } sub set_symbolname { my ($self, $name, $templ, $quoted) = @_; $name //= $self->{symbol}; if (!defined $templ && $name =~ /\s/) { $templ = $name; } if (!defined $quoted && defined $templ && $templ =~ /\s/) { $quoted = '"'; } $self->{symbol} = $name; $self->{symbol_templ} = $templ; if ($quoted) { $self->{symbol_quoted} = $quoted; } else { delete $self->{symbol_quoted}; } } sub has_tags { my $self = shift; return scalar (@{$self->{tagorder}}); } sub add_tag { my ($self, $tagname, $tagval) = @_; if (exists $self->{tags}{$tagname}) { $self->{tags}{$tagname} = $tagval; return 0; } else { $self->{tags}{$tagname} = $tagval; push @{$self->{tagorder}}, $tagname; } return 1; } sub delete_tag { my ($self, $tagname) = @_; if (exists $self->{tags}{$tagname}) { delete $self->{tags}{$tagname}; $self->{tagorder} = [ grep { $_ ne $tagname } @{$self->{tagorder}} ]; return 1; } return 0; } sub has_tag { my ($self, $tag) = @_; return exists $self->{tags}{$tag}; } sub get_tag_value { my ($self, $tag) = @_; return $self->{tags}{$tag}; } # Checks if the symbol is equal to another one (by name and optionally, # tag sets, versioning info (minver and depid)) sub equals { my ($self, $other, %opts) = @_; $opts{versioning} //= 1; $opts{tags} //= 1; return 0 if $self->{symbol} ne $other->{symbol}; if ($opts{versioning}) { return 0 if $self->{minver} ne $other->{minver}; return 0 if $self->{dep_id} ne $other->{dep_id}; } if ($opts{tags}) { return 0 if scalar(@{$self->{tagorder}}) != scalar(@{$other->{tagorder}}); for my $i (0 .. scalar(@{$self->{tagorder}}) - 1) { my $tag = $self->{tagorder}->[$i]; return 0 if $tag ne $other->{tagorder}->[$i]; if (defined $self->{tags}{$tag} && defined $other->{tags}{$tag}) { return 0 if $self->{tags}{$tag} ne $other->{tags}{$tag}; } elsif (defined $self->{tags}{$tag} || defined $other->{tags}{$tag}) { return 0; } } } return 1; } sub is_optional { my $self = shift; return $self->has_tag('optional'); } sub is_arch_specific { my $self = shift; return $self->has_tag('arch'); } sub arch_is_concerned { my ($self, $arch) = @_; my $arches = $self->{tags}{arch}; return 0 if defined $arch && defined $arches && !debarch_is_concerned($arch, split /[\s,]+/, $arches); my ($bits, $endian) = debarch_to_abiattrs($arch); return 0 if defined $bits && defined $self->{tags}{'arch-bits'} && $bits ne $self->{tags}{'arch-bits'}; return 0 if defined $endian && defined $self->{tags}{'arch-endian'} && $endian ne $self->{tags}{'arch-endian'}; return 1; } # Get reference to the pattern the symbol matches (if any) sub get_pattern { my $self = shift; return $self->{matching_pattern}; } ### NOTE: subroutines below require (or initialize) $self to be a pattern ### # Initializes this symbol as a pattern of the specified type. sub init_pattern { my ($self, $type) = @_; $self->{pattern}{type} = $type; # To be filled with references to symbols matching this pattern. $self->{pattern}{matches} = []; } # Is this symbol a pattern or not? sub is_pattern { my $self = shift; return exists $self->{pattern}; } # Get pattern type if this symbol is a pattern. sub get_pattern_type { my $self = shift; return $self->{pattern}{type} // ''; } # Get (sub)type of the alias pattern. Returns empty string if current # pattern is not alias. sub get_alias_type { my $self = shift; return ($self->get_pattern_type() =~ /^alias-(.+)/ && $1) || ''; } # Get a list of symbols matching this pattern if this symbol is a pattern sub get_pattern_matches { my $self = shift; return @{$self->{pattern}{matches}}; } # Create a new symbol based on the pattern (i.e. $self) # and add it to the pattern matches list. sub create_pattern_match { my $self = shift; return unless $self->is_pattern(); # Leave out 'pattern' subfield while deep-cloning my $pattern_stuff = $self->{pattern}; delete $self->{pattern}; my $newsym = $self->clone(@_); $self->{pattern} = $pattern_stuff; # Clean up symbol name related internal fields $newsym->set_symbolname(); # Set newsym pattern reference, add to pattern matches list $newsym->{matching_pattern} = $self; push @{$self->{pattern}{matches}}, $newsym; return $newsym; } ### END of pattern subroutines ### # Given a raw symbol name the call returns its alias according to the rules of # the current pattern ($self). Returns undef if the supplied raw name is not # transformable to alias. sub convert_to_alias { my ($self, $rawname, $type) = @_; $type = $self->get_alias_type() unless $type; if ($type) { if ($type eq 'symver') { # In case of symver, alias is symbol version. Extract it from the # rawname. return "$1" if ($rawname =~ /\@([^@]+)$/); } elsif ($rawname =~ /^_Z/ && $type eq 'c++') { return cppfilt_demangle_cpp($rawname); } } return; } sub get_tagspec { my $self = shift; if ($self->has_tags()) { my @tags; for my $tagname (@{$self->{tagorder}}) { my $tagval = $self->{tags}{$tagname}; if (defined $tagval) { push @tags, $tagname . '=' . $tagval; } else { push @tags, $tagname; } } return '(' . join('|', @tags) . ')'; } return ''; } sub get_symbolspec { my $self = shift; my $template_mode = shift; my $spec = ''; $spec .= "#MISSING: $self->{deprecated}#" if $self->{deprecated}; $spec .= ' '; if ($template_mode) { if ($self->has_tags()) { $spec .= sprintf('%s%3$s%s%3$s', $self->get_tagspec(), $self->get_symboltempl(), $self->{symbol_quoted} // ''); } else { $spec .= $self->get_symboltempl(); } } else { $spec .= $self->get_symbolname(); } $spec .= " $self->{minver}"; $spec .= " $self->{dep_id}" if $self->{dep_id}; return $spec; } # Sanitize the symbol when it is confirmed to be found in # the respective library. sub mark_found_in_library { my ($self, $minver, $arch) = @_; if ($self->{deprecated}) { # Symbol reappeared somehow $self->{deprecated} = 0; $self->{minver} = $minver if (not $self->is_optional()); } else { # We assume that the right dependency information is already # there. if (version_compare($minver, $self->{minver}) < 0) { $self->{minver} = $minver; } } # Never remove arch tags from patterns if (not $self->is_pattern()) { if (not $self->arch_is_concerned($arch)) { # Remove arch tags because they are incorrect. $self->delete_tag('arch'); $self->delete_tag('arch-bits'); $self->delete_tag('arch-endian'); } } } # Sanitize the symbol when it is confirmed to be NOT found in # the respective library. # Mark as deprecated those that are no more provided (only if the # minver is later than the version where the symbol was introduced) sub mark_not_found_in_library { my ($self, $minver, $arch) = @_; # Ignore symbols from foreign arch return if not $self->arch_is_concerned($arch); if ($self->{deprecated}) { # Bump deprecated if the symbol is optional so that it # keeps reappearing in the diff while it's missing $self->{deprecated} = $minver if $self->is_optional(); } elsif (version_compare($minver, $self->{minver}) > 0) { $self->{deprecated} = $minver; } } # Checks if the symbol (or pattern) is legitimate as a real symbol for the # specified architecture. sub is_legitimate { my ($self, $arch) = @_; return ! $self->{deprecated} && $self->arch_is_concerned($arch); } # Determine whether a supplied raw symbol name matches against current ($self) # symbol or pattern. sub matches_rawname { my ($self, $rawname) = @_; my $target = $rawname; my $ok = 1; my $do_eq_match = 1; if ($self->is_pattern()) { # Process pattern tags in the order they were specified. for my $tag (@{$self->{tagorder}}) { if (any { $tag eq $_ } ALIAS_TYPES) { $ok = not not ($target = $self->convert_to_alias($target, $tag)); } elsif ($tag eq 'regex') { # Symbol name is a regex. Match it against the target $do_eq_match = 0; $ok = ($target =~ $self->{pattern}{regex}); } last if not $ok; } } # Equality match by default if ($ok && $do_eq_match) { $ok = $target eq $self->get_symbolname(); } return $ok; } 1; PK ! �<X�&; &; Arch.pmnu �[��� # Copyright © 2006-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::Arch; =encoding utf8 =head1 NAME Dpkg::Arch - handle architectures =head1 DESCRIPTION The Dpkg::Arch module provides functions to handle Debian architectures, wildcards, and mapping from and to GNU triplets. No symbols are exported by default. The :all tag can be used to import all symbols. The :getters, :parsers, :mappers and :operators tags can be used to import specific symbol subsets. =cut use strict; use warnings; use feature qw(state); our $VERSION = '1.03'; our @EXPORT_OK = qw( get_raw_build_arch get_raw_host_arch get_build_arch get_host_arch get_host_gnu_type get_valid_arches debarch_eq debarch_is debarch_is_wildcard debarch_is_illegal debarch_is_concerned debarch_to_abiattrs debarch_to_cpubits debarch_to_gnutriplet debarch_to_debtuple debarch_to_multiarch debarch_list_parse debtuple_to_debarch debtuple_to_gnutriplet gnutriplet_to_debarch gnutriplet_to_debtuple gnutriplet_to_multiarch ); our %EXPORT_TAGS = ( all => [ @EXPORT_OK ], getters => [ qw( get_raw_build_arch get_raw_host_arch get_build_arch get_host_arch get_host_gnu_type get_valid_arches ) ], parsers => [ qw( debarch_list_parse ) ], mappers => [ qw( debarch_to_abiattrs debarch_to_gnutriplet debarch_to_debtuple debarch_to_multiarch debtuple_to_debarch debtuple_to_gnutriplet gnutriplet_to_debarch gnutriplet_to_debtuple gnutriplet_to_multiarch ) ], operators => [ qw( debarch_eq debarch_is debarch_is_wildcard debarch_is_illegal debarch_is_concerned ) ], ); use Exporter qw(import); use List::Util qw(any); use Dpkg (); use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Build::Env; my (@cpu, @os); my (%cputable, %ostable); my (%cputable_re, %ostable_re); my (%cpubits, %cpuendian); my %abibits; my %debtuple_to_debarch; my %debarch_to_debtuple; =head1 FUNCTIONS =over 4 =item $arch = get_raw_build_arch() Get the raw build Debian architecture, without taking into account variables from the environment. =cut sub get_raw_build_arch() { state $build_arch; return $build_arch if defined $build_arch; # Note: We *always* require an installed dpkg when inferring the # build architecture. The bootstrapping case is handled by # dpkg-architecture itself, by avoiding computing the DEB_BUILD_ # variables when they are not requested. ## no critic (TestingAndDebugging::ProhibitNoWarnings) no warnings qw(exec); $build_arch = qx(dpkg --print-architecture); syserr('dpkg --print-architecture failed') if $? >> 8; chomp $build_arch; return $build_arch; } =item $arch = get_build_arch() Get the build Debian architecture, using DEB_BUILD_ARCH from the environment if available. =cut sub get_build_arch() { return Dpkg::Build::Env::get('DEB_BUILD_ARCH') || get_raw_build_arch(); } { my %cc_host_gnu_type; sub get_host_gnu_type() { my $CC = $ENV{CC} || 'gcc'; return $cc_host_gnu_type{$CC} if defined $cc_host_gnu_type{$CC}; ## no critic (TestingAndDebugging::ProhibitNoWarnings) no warnings qw(exec); $cc_host_gnu_type{$CC} = qx($CC -dumpmachine); if ($? >> 8) { $cc_host_gnu_type{$CC} = ''; } else { chomp $cc_host_gnu_type{$CC}; } return $cc_host_gnu_type{$CC}; } sub set_host_gnu_type { my ($host_gnu_type) = @_; my $CC = $ENV{CC} || 'gcc'; $cc_host_gnu_type{$CC} = $host_gnu_type; } } =item $arch = get_raw_host_arch() Get the raw host Debian architecture, without taking into account variables from the environment. =cut sub get_raw_host_arch() { state $host_arch; return $host_arch if defined $host_arch; my $host_gnu_type = get_host_gnu_type(); if ($host_gnu_type eq '') { warning(g_('cannot determine CC system type, falling back to ' . 'default (native compilation)')); } else { my (@host_archtuple) = gnutriplet_to_debtuple($host_gnu_type); $host_arch = debtuple_to_debarch(@host_archtuple); if (defined $host_arch) { $host_gnu_type = debtuple_to_gnutriplet(@host_archtuple); } else { warning(g_('unknown CC system type %s, falling back to ' . 'default (native compilation)'), $host_gnu_type); $host_gnu_type = ''; } set_host_gnu_type($host_gnu_type); } if (!defined($host_arch)) { # Switch to native compilation. $host_arch = get_raw_build_arch(); } return $host_arch; } =item $arch = get_host_arch() Get the host Debian architecture, using DEB_HOST_ARCH from the environment if available. =cut sub get_host_arch() { return Dpkg::Build::Env::get('DEB_HOST_ARCH') || get_raw_host_arch(); } =item @arch_list = get_valid_arches() Get an array with all currently known Debian architectures. =cut sub get_valid_arches() { _load_cputable(); _load_ostable(); my @arches; foreach my $os (@os) { foreach my $cpu (@cpu) { my $arch = debtuple_to_debarch(split(/-/, $os, 3), $cpu); push @arches, $arch if defined($arch); } } return @arches; } my %table_loaded; sub _load_table { my ($table, $loader) = @_; return if $table_loaded{$table}; local $_; local $/ = "\n"; open my $table_fh, '<', "$Dpkg::DATADIR/$table" or syserr(g_('cannot open %s'), $table); while (<$table_fh>) { $loader->($_); } close $table_fh; $table_loaded{$table} = 1; } sub _load_cputable { _load_table('cputable', sub { if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) { $cputable{$1} = $2; $cputable_re{$1} = $3; $cpubits{$1} = $4; $cpuendian{$1} = $5; push @cpu, $1; } }); } sub _load_ostable { _load_table('ostable', sub { if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) { $ostable{$1} = $2; $ostable_re{$1} = $3; push @os, $1; } }); } sub _load_abitable() { _load_table('abitable', sub { if (m/^(?!\#)(\S+)\s+(\S+)/) { $abibits{$1} = $2; } }); } sub _load_tupletable() { _load_cputable(); _load_table('tupletable', sub { if (m/^(?!\#)(\S+)\s+(\S+)/) { my $debtuple = $1; my $debarch = $2; if ($debtuple =~ /<cpu>/) { foreach my $_cpu (@cpu) { (my $dt = $debtuple) =~ s/<cpu>/$_cpu/; (my $da = $debarch) =~ s/<cpu>/$_cpu/; next if exists $debarch_to_debtuple{$da} or exists $debtuple_to_debarch{$dt}; $debarch_to_debtuple{$da} = $dt; $debtuple_to_debarch{$dt} = $da; } } else { $debarch_to_debtuple{$2} = $1; $debtuple_to_debarch{$1} = $2; } } }); } sub debtuple_to_gnutriplet(@) { my ($abi, $libc, $os, $cpu) = @_; _load_cputable(); _load_ostable(); return unless defined $abi && defined $libc && defined $os && defined $cpu && exists $cputable{$cpu} && exists $ostable{"$abi-$libc-$os"}; return join('-', $cputable{$cpu}, $ostable{"$abi-$libc-$os"}); } sub gnutriplet_to_debtuple($) { my $gnu = shift; return unless defined($gnu); my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2); return unless defined($gnu_cpu) && defined($gnu_os); _load_cputable(); _load_ostable(); my ($os, $cpu); foreach my $_cpu (@cpu) { if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) { $cpu = $_cpu; last; } } foreach my $_os (@os) { if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) { $os = $_os; last; } } return if !defined($cpu) || !defined($os); return (split(/-/, $os, 3), $cpu); } =item $multiarch = gnutriplet_to_multiarch($gnutriplet) Map a GNU triplet into a Debian multiarch triplet. =cut sub gnutriplet_to_multiarch($) { my $gnu = shift; my ($cpu, $cdr) = split(/-/, $gnu, 2); if ($cpu =~ /^i[4567]86$/) { return "i386-$cdr"; } else { return $gnu; } } =item $multiarch = debarch_to_multiarch($arch) Map a Debian architecture into a Debian multiarch triplet. =cut sub debarch_to_multiarch($) { my $arch = shift; return gnutriplet_to_multiarch(debarch_to_gnutriplet($arch)); } sub debtuple_to_debarch(@) { my ($abi, $libc, $os, $cpu) = @_; _load_tupletable(); if (!defined $abi || !defined $libc || !defined $os || !defined $cpu) { return; } elsif (exists $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}) { return $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}; } else { return; } } sub debarch_to_debtuple($) { my $arch = shift; return if not defined $arch; _load_tupletable(); if ($arch =~ /^linux-([^-]*)/) { # XXX: Might disappear in the future, not sure yet. $arch = $1; } my $tuple = $debarch_to_debtuple{$arch}; if (defined($tuple)) { my @tuple = split /-/, $tuple, 4; return @tuple if wantarray; return { abi => $tuple[0], libc => $tuple[1], os => $tuple[2], cpu => $tuple[3], }; } else { return; } } =item $gnutriplet = debarch_to_gnutriplet($arch) Map a Debian architecture into a GNU triplet. =cut sub debarch_to_gnutriplet($) { my $arch = shift; return debtuple_to_gnutriplet(debarch_to_debtuple($arch)); } =item $arch = gnutriplet_to_debarch($gnutriplet) Map a GNU triplet into a Debian architecture. =cut sub gnutriplet_to_debarch($) { my $gnu = shift; return debtuple_to_debarch(gnutriplet_to_debtuple($gnu)); } sub debwildcard_to_debtuple($) { my $arch = shift; my @tuple = split /-/, $arch, 4; if (any { $_ eq 'any' } @tuple) { if (scalar @tuple == 4) { return @tuple; } elsif (scalar @tuple == 3) { return ('any', @tuple); } elsif (scalar @tuple == 2) { return ('any', 'any', @tuple); } else { return ('any', 'any', 'any', 'any'); } } else { return debarch_to_debtuple($arch); } } sub debarch_to_abiattrs($) { my $arch = shift; my ($abi, $libc, $os, $cpu) = debarch_to_debtuple($arch); if (defined($cpu)) { _load_abitable(); return ($abibits{$abi} // $cpubits{$cpu}, $cpuendian{$cpu}); } else { return; } } sub debarch_to_cpubits($) { my $arch = shift; my (undef, undef, undef, $cpu) = debarch_to_debtuple($arch); if (defined $cpu) { return $cpubits{$cpu}; } else { return; } } =item $bool = debarch_eq($arch_a, $arch_b) Evaluate the equality of a Debian architecture, by comparing with another Debian architecture. No wildcard matching is performed. =cut sub debarch_eq($$) { my ($a, $b) = @_; return 1 if ($a eq $b); my @a = debarch_to_debtuple($a); my @b = debarch_to_debtuple($b); return 0 if scalar @a != 4 or scalar @b != 4; return $a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2] && $a[3] eq $b[3]; } =item $bool = debarch_is($arch, $arch_wildcard) Evaluate the identity of a Debian architecture, by matching with an architecture wildcard. =cut sub debarch_is($$) { my ($real, $alias) = @_; return 1 if ($alias eq $real or $alias eq 'any'); my @real = debarch_to_debtuple($real); my @alias = debwildcard_to_debtuple($alias); return 0 if scalar @real != 4 or scalar @alias != 4; if (($alias[0] eq $real[0] || $alias[0] eq 'any') && ($alias[1] eq $real[1] || $alias[1] eq 'any') && ($alias[2] eq $real[2] || $alias[2] eq 'any') && ($alias[3] eq $real[3] || $alias[3] eq 'any')) { return 1; } return 0; } =item $bool = debarch_is_wildcard($arch) Evaluate whether a Debian architecture is an architecture wildcard. =cut sub debarch_is_wildcard($) { my $arch = shift; return 0 if $arch eq 'all'; my @tuple = debwildcard_to_debtuple($arch); return 0 if scalar @tuple != 4; return 1 if any { $_ eq 'any' } @tuple; return 0; } =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, %opts) = @_; my $arch_re = qr/[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) Evaluate whether a Debian architecture applies to the list of architecture restrictions, as usually found in dependencies inside square brackets. =cut sub debarch_is_concerned { my ($host_arch, @arches) = @_; my $seen_arch = 0; foreach my $arch (@arches) { $arch = lc $arch; if ($arch =~ /^!/) { my $not_arch = $arch; $not_arch =~ s/^!//; if (debarch_is($host_arch, $not_arch)) { $seen_arch = 0; last; } else { # !arch includes by default all other arches # unless they also appear in a !otherarch $seen_arch = 1; } } elsif (debarch_is($host_arch, $arch)) { $seen_arch = 1; last; } } return $seen_arch; } =item @array = debarch_list_parse($arch_list, %options) 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, %opts) = @_; my @arch_list = split ' ', $arch_list; foreach my $arch (@arch_list) { if (debarch_is_illegal($arch, %opts)) { error(g_("'%s' is not a legal architecture in list '%s'"), $arch, $arch_list); } } return @arch_list; } 1; __END__ =back =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". =head2 Version 1.01 (dpkg 1.18.5) New functions: debarch_is_illegal(), debarch_list_parse(). =head2 Version 1.00 (dpkg 1.18.2) Mark the module as public. =head1 SEE ALSO dpkg-architecture(1). PK ! � �� Shlibs.pmnu �[��� # Copyright © 2007, 2016 Raphaël Hertzog <hertzog@debian.org> # Copyright © 2007-2008, 2012-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::Shlibs; use strict; use warnings; use feature qw(state); our $VERSION = '0.03'; our @EXPORT_OK = qw( blank_library_paths setup_library_paths get_library_paths add_library_dir find_library ); use Exporter qw(import); use List::Util qw(none); use File::Spec; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Shlibs::Objdump; use Dpkg::Path qw(resolve_symlink canonpath); use Dpkg::Arch qw(get_build_arch get_host_arch :mappers); use constant DEFAULT_LIBRARY_PATH => qw(/lib /usr/lib); # XXX: Deprecated multilib paths. use constant DEFAULT_MULTILIB_PATH => qw(/lib32 /usr/lib32 /lib64 /usr/lib64); # Library paths set by the user. my @custom_librarypaths; # Library paths from the system. my @system_librarypaths; my $librarypaths_init; sub parse_ldso_conf { my $file = shift; state %visited; local $_; open my $fh, '<', $file or syserr(g_('cannot open %s'), $file); $visited{$file}++; while (<$fh>) { next if /^\s*$/; chomp; s{/+$}{}; if (/^include\s+(\S.*\S)\s*$/) { foreach my $include (glob($1)) { parse_ldso_conf($include) if -e $include && !$visited{$include}; } } elsif (m{^\s*/}) { s/^\s+//; my $libdir = $_; if (none { $_ eq $libdir } (@custom_librarypaths, @system_librarypaths)) { push @system_librarypaths, $libdir; } } } close $fh; } sub blank_library_paths { @custom_librarypaths = (); @system_librarypaths = (); $librarypaths_init = 1; } sub setup_library_paths { @custom_librarypaths = (); @system_librarypaths = (); # 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; } } # Adjust set of directories to consider when we're in a situation of a # cross-build or a build of a cross-compiler. my $multiarch; # Detect cross compiler builds. if ($ENV{DEB_TARGET_GNU_TYPE} and ($ENV{DEB_TARGET_GNU_TYPE} ne $ENV{DEB_BUILD_GNU_TYPE})) { $multiarch = gnutriplet_to_multiarch($ENV{DEB_TARGET_GNU_TYPE}); } # Host for normal cross builds. if (get_build_arch() ne get_host_arch()) { $multiarch = debarch_to_multiarch(get_host_arch()); } # Define list of directories containing crossbuilt libraries. if ($multiarch) { push @system_librarypaths, "/lib/$multiarch", "/usr/lib/$multiarch"; } push @system_librarypaths, DEFAULT_LIBRARY_PATH; # Update library paths with ld.so config. parse_ldso_conf('/etc/ld.so.conf') if -e '/etc/ld.so.conf'; push @system_librarypaths, DEFAULT_MULTILIB_PATH; $librarypaths_init = 1; } sub add_library_dir { my $dir = shift; setup_library_paths() if not $librarypaths_init; push @custom_librarypaths, $dir; } sub get_library_paths { setup_library_paths() if not $librarypaths_init; return (@custom_librarypaths, @system_librarypaths); } # find_library ($soname, \@rpath, $format, $root) sub find_library { my ($lib, $rpath, $format, $root) = @_; setup_library_paths() if not $librarypaths_init; my @librarypaths = (@{$rpath}, @custom_librarypaths, @system_librarypaths); my @libs; $root //= ''; $root =~ s{/+$}{}; foreach my $dir (@librarypaths) { my $checkdir = "$root$dir"; if (-e "$checkdir/$lib") { my $libformat = Dpkg::Shlibs::Objdump::get_format("$checkdir/$lib"); if ($format eq $libformat) { push @libs, canonpath("$checkdir/$lib"); } else { debug(1, "Skipping lib $checkdir/$lib, libabi=0x%s != objabi=0x%s", unpack('H*', $libformat), unpack('H*', $format)); } } } return @libs; } 1; PK ! ��R � � BuildProfiles.pmnu �[��� # Copyright © 2013 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::BuildProfiles; use strict; use warnings; our $VERSION = '1.00'; our @EXPORT_OK = qw( get_build_profiles set_build_profiles parse_build_profiles evaluate_restriction_formula ); use Exporter qw(import); use List::Util qw(any); use Dpkg::Build::Env; use Dpkg::Vendor qw(run_vendor_hook); my $cache_profiles; my @build_profiles; =encoding utf8 =head1 NAME Dpkg::BuildProfiles - handle build profiles =head1 DESCRIPTION The Dpkg::BuildProfiles module provides functions to handle the build profiles. =head1 FUNCTIONS =over 4 =item @profiles = get_build_profiles() Get an array with the currently active build profiles, taken from the environment variable B<DEB_BUILD_PROFILES>. =cut sub get_build_profiles { return @build_profiles if $cache_profiles; if (Dpkg::Build::Env::has('DEB_BUILD_PROFILES')) { @build_profiles = split ' ', Dpkg::Build::Env::get('DEB_BUILD_PROFILES'); } $cache_profiles = 1; run_vendor_hook('update-buildprofiles', \@build_profiles); return @build_profiles; } =item set_build_profiles(@profiles) Set C<@profiles> as the current active build profiles, by setting the environment variable B<DEB_BUILD_PROFILES>. =cut sub set_build_profiles { my (@profiles) = @_; $cache_profiles = 1; # This is called from dpkg-buildpackage.pl unconditionally. If no profile # was passed from the command line, check the environment variable. if (!@profiles && Dpkg::Build::Env::has('DEB_BUILD_PROFILES')) { @profiles = split ' ', Dpkg::Build::Env::get('DEB_BUILD_PROFILES'); } @build_profiles = @profiles; run_vendor_hook('update-buildprofiles', \@build_profiles); Dpkg::Build::Env::set('DEB_BUILD_PROFILES', join ' ', @build_profiles); } =item @profiles = parse_build_profiles($string) Parses a build profiles specification, into an array of array references. =cut sub parse_build_profiles { my $string = shift; $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; return map { [ split ' ' ] } split /\s*>\s+<\s*/, $string; } =item evaluate_restriction_formula(\@formula, \@profiles) Evaluate whether a restriction formula of the form "<foo bar> <baz>", given as a nested array, is true or false, given the array of enabled build profiles. =cut sub evaluate_restriction_formula { my ($formula, $profiles) = @_; # Restriction formulas are in disjunctive normal form: # (foo AND bar) OR (blub AND bla) foreach my $restrlist (@{$formula}) { my $seen_profile = 1; foreach my $restriction (@$restrlist) { next if $restriction !~ m/^(!)?(.+)/; my $negated = defined $1 && $1 eq '!'; my $profile = $2; my $found = any { $_ eq $profile } @{$profiles}; # If a negative set profile is encountered, stop processing. # If a positive unset profile is encountered, stop processing. if ($found == $negated) { $seen_profile = 0; last; } } # This conjunction evaluated to true so we don't have to evaluate # the others. return 1 if $seen_profile; } return 0; } =back =head1 CHANGES =head2 Version 1.00 (dpkg 1.17.17) Mark the module as public. =cut 1; PK ! ��s Package.pmnu �[��� # Copyright © 2006 Frank Lichtenheld <djpig@debian.org> # Copyright © 2007,2012 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::Package; use strict; use warnings; our $VERSION = '0.01'; our @EXPORT = qw( pkg_name_is_illegal ); use Exporter qw(import); use Dpkg::Gettext; sub pkg_name_is_illegal($) { my $name = shift // ''; if ($name eq '') { return g_('may not be empty string'); } if ($name =~ m/[^-+.0-9a-z]/op) { return sprintf(g_("character '%s' not allowed"), ${^MATCH}); } if ($name !~ m/^[0-9a-z]/o) { return g_('must start with an alphanumeric character'); } return; } 1; PK ! ��A�� � ErrorHandling.pmnu �[��� # 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::ErrorHandling; use strict; use warnings; use feature qw(state); our $VERSION = '0.02'; our @EXPORT_OK = qw( REPORT_PROGNAME REPORT_COMMAND REPORT_STATUS REPORT_DEBUG REPORT_INFO REPORT_NOTICE REPORT_WARN REPORT_ERROR report_pretty report_color report ); our @EXPORT = qw( report_options debug info notice warning error errormsg syserr printcmd subprocerr usageerr ); use Exporter qw(import); use Dpkg (); use Dpkg::Gettext; my $quiet_warnings = 0; my $debug_level = 0; my $info_fh = \*STDOUT; sub setup_color { my $mode = $ENV{'DPKG_COLORS'} // 'auto'; my $use_color; if ($mode eq 'auto') { ## no critic (InputOutput::ProhibitInteractiveTest) $use_color = 1 if -t *STDOUT or -t *STDERR; } elsif ($mode eq 'always') { $use_color = 1; } else { $use_color = 0; } require Term::ANSIColor if $use_color; } use constant { REPORT_PROGNAME => 1, REPORT_COMMAND => 2, REPORT_STATUS => 3, REPORT_INFO => 4, REPORT_NOTICE => 5, REPORT_WARN => 6, REPORT_ERROR => 7, REPORT_DEBUG => 8, }; my %report_mode = ( REPORT_PROGNAME() => { color => 'bold', }, REPORT_COMMAND() => { color => 'bold magenta', }, REPORT_STATUS() => { color => 'clear', # We do not translate this name because the untranslated output is # part of the interface. name => 'status', }, REPORT_DEBUG() => { color => 'clear', # We do not translate this name because it is a developer interface # and all debug messages are untranslated anyway. name => 'debug', }, REPORT_INFO() => { color => 'green', name => g_('info'), }, REPORT_NOTICE() => { color => 'yellow', name => g_('notice'), }, REPORT_WARN() => { color => 'bold yellow', name => g_('warning'), }, REPORT_ERROR() => { color => 'bold red', name => g_('error'), }, ); sub report_options { my (%options) = @_; if (exists $options{quiet_warnings}) { $quiet_warnings = $options{quiet_warnings}; } if (exists $options{debug_level}) { $debug_level = $options{debug_level}; } if (exists $options{info_fh}) { $info_fh = $options{info_fh}; } } sub report_name { my $type = shift; return $report_mode{$type}{name} // ''; } sub report_color { my $type = shift; return $report_mode{$type}{color} // 'clear'; } sub report_pretty { my ($msg, $color) = @_; state $use_color = setup_color(); if ($use_color) { return Term::ANSIColor::colored($msg, $color); } else { return $msg; } } sub _progname_prefix { return report_pretty("$Dpkg::PROGNAME: ", report_color(REPORT_PROGNAME)); } sub _typename_prefix { my $type = shift; return report_pretty(report_name($type), report_color($type)); } sub report(@) { my ($type, $msg) = (shift, shift); $msg = sprintf($msg, @_) if (@_); my $progname = _progname_prefix(); my $typename = _typename_prefix($type); return "$progname$typename: $msg\n"; } sub debug { my $level = shift; print report(REPORT_DEBUG, @_) if $level <= $debug_level; } sub info($;@) { print { $info_fh } report(REPORT_INFO, @_) if not $quiet_warnings; } sub notice { warn report(REPORT_NOTICE, @_) if not $quiet_warnings; } sub warning($;@) { warn report(REPORT_WARN, @_) if not $quiet_warnings; } sub syserr($;@) { my $msg = shift; die report(REPORT_ERROR, "$msg: $!", @_); } sub error($;@) { die report(REPORT_ERROR, @_); } sub errormsg($;@) { print { *STDERR } report(REPORT_ERROR, @_); } sub printcmd { my (@cmd) = @_; print { *STDERR } report_pretty(" @cmd\n", report_color(REPORT_COMMAND)); } sub subprocerr(@) { my ($p) = (shift); $p = sprintf($p, @_) if (@_); require POSIX; if (POSIX::WIFEXITED($?)) { my $ret = POSIX::WEXITSTATUS($?); error(g_('%s subprocess returned exit status %d'), $p, $ret); } elsif (POSIX::WIFSIGNALED($?)) { my $sig = POSIX::WTERMSIG($?); error(g_('%s subprocess was killed by signal %d'), $p, $sig); } else { error(g_('%s subprocess failed with unknown status code %d'), $p, $?); } } sub usageerr(@) { my ($msg) = (shift); state $printforhelp = g_('Use --help for program usage information.'); $msg = sprintf($msg, @_) if (@_); warn report(REPORT_ERROR, $msg); warn "\n$printforhelp\n"; exit(2); } 1; PK ! }���u u OpenPGP.pmnu �[��� # Copyright © 2017 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::OpenPGP; use strict; use warnings; use POSIX qw(:sys_wait_h); use Exporter qw(import); use File::Temp; use File::Copy; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::IPC; use Dpkg::Path qw(find_command); our $VERSION = '0.01'; our @EXPORT = qw( openpgp_sig_to_asc ); sub _armor_gpg { my ($sig, $asc) = @_; 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', @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/; print { $fh_asc } $line; } close $fh_gpg or subprocerr('gpg'); close $fh_asc or syserr(g_('cannot write signature file %s'), $asc); return $asc; } sub openpgp_sig_to_asc { my ($sig, $asc) = @_; if (-e $sig) { my $is_openpgp_ascii_armor = 0; open my $fh_sig, '<', $sig or syserr(g_('cannot open %s'), $sig); while (<$fh_sig>) { if (m/^-----BEGIN PGP /) { $is_openpgp_ascii_armor = 1; last; } } close $fh_sig; if ($is_openpgp_ascii_armor) { notice(g_('signature file is already OpenPGP ASCII armor, copying')); copy($sig, $asc); return $asc; } if (find_command('gpg')) { return _armor_gpg($sig, $asc); } else { warning(g_('cannot OpenPGP ASCII armor signature file due to missing gpg')); } } return; } sub _exec_openpgp { my ($exec, $exec_opts, $opts, $errmsg) = @_; my ($stdout, $stderr); spawn(exec => $exec, wait_child => 1, nocheck => 1, timeout => 10, to_string => \$stdout, error_to_string => \$stderr, %{$exec_opts}); if (WIFEXITED($?)) { my $status = WEXITSTATUS($?); print { *STDERR } "$stdout$stderr" if $status; if ($status == 1 or ($status && $opts->{require_valid_signature})) { error($errmsg); } elsif ($status) { warning($errmsg); } } else { subprocerr("@{$exec}"); } } 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; } my $gpghome = File::Temp->newdir('dpkg-import-key.XXXXXXXX', TMPDIR => 1); push @exec, '--homedir', $gpghome; push @exec, '--no-options', '--no-default-keyring', '-q', '--import'; push @exec, '--keyring', $opts{keyring}; push @exec, $asc; my $errmsg = sprintf g_('cannot import key %s into %s'), $asc, $opts{keyring}; _exec_openpgp(\@exec, {}, \%opts, $errmsg); } sub verify_signature { my ($sig, %opts) = @_; $opts{require_valid_signature} //= 1; my @gpg_weak_digest = map { (qw(--weak-digest), $_) } qw(SHA1 RIPEMD160); my @exec; if (find_command('gpgv')) { push @exec, 'gpgv', @gpg_weak_digest; } elsif (find_command('gpg')) { my @gpg_opts = (qw(--no-options --no-default-keyring -q), @gpg_weak_digest); push @exec, 'gpg', @gpg_opts, '--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; } my $gpghome = File::Temp->newdir('dpkg-verify-sig.XXXXXXXX', TMPDIR => 1); push @exec, '--homedir', $gpghome; foreach my $keyring (@{$opts{keyrings}}) { push @exec, '--keyring', $keyring; } push @exec, $sig; push @exec, $opts{datafile} if exists $opts{datafile}; my $errmsg = sprintf g_('cannot verify signature %s'), $sig; _exec_openpgp(\@exec, {}, \%opts, $errmsg); } 1; PK ! _� ��, �, Substvars.pmnu �[��� PK ! ί��O! O! - Changelog/Debian.pmnu �[��� PK ! �0��D- D- �N Changelog/Entry/Debian.pmnu �[��� PK ! �2�4 4 =| Changelog/Entry.pmnu �[��� PK ! ڀ@�� � �� Changelog/Parse.pmnu �[��� PK ! ��m� � � Gettext.pmnu �[��� PK ! T��� �� Lock.pmnu �[��� PK ! ��Vv v e� Control/Tests/Entry.pmnu �[��� PK ! *&�� !� Control/Info.pmnu �[��� PK ! f��� � ~� Control/Hash.pmnu �[��� PK ! ��� � �� Control/Changelog.pmnu �[��� PK ! ��/� � a� Control/Tests.pmnu �[��� PK ! ���n�s �s �� Control/FieldsCore.pmnu �[��� PK ! ˆ�? ? jq Control/Fields.pmnu �[��� PK ! |�Q��= �= �y Control/HashCore.pmnu �[��� PK ! QŽ`~ ~ �� Control/Types.pmnu �[��� PK ! l0� � File.pmnu �[��� PK ! �Ȗ?� � �� Vars.pmnu �[��� PK ! 0$~� 3 3 �� Version.pmnu �[��� PK ! �=Aԯ. �. � BuildFlags.pmnu �[��� PK ! 3���+ �+ �/ Checksums.pmnu �[��� PK ! �'1� � �[ BuildOptions.pmnu �[��� PK ! a�!B� � �t Getopt.pmnu �[��� PK ! ��:~. ~. �y IPC.pmnu �[��� PK ! �," " �� Conf.pmnu �[��� PK ! p�7>Y Y �� Source/Patch.pmnu �[��� PK ! J v�� � N Source/BinaryFiles.pmnu �[��� PK ! ���� � 4- Source/Format.pmnu �[��� PK ! e{)�J- J- M> Source/Quilt.pmnu �[��� PK ! qg M@! @! �k Source/Archive.pmnu �[��� PK ! op���K �K W� Source/Package.pmnu �[��� PK ! �=�)� � 8� Source/Functions.pmnu �[��� PK ! T`dOcF cF B� Source/Package/V1.pmnu �[��� PK ! ��J� � �. Source/Package/V3/Custom.pmnu �[��� PK ! I^Z> > �6 Source/Package/V3/Bzr.pmnu �[��� PK ! q� �� � XP Source/Package/V3/Quilt.pmnu �[��� PK ! _�$�8 8 Yp Source/Package/V3/Git.pmnu �[��� PK ! U� �� � ُ Source/Package/V3/Native.pmnu �[��� PK ! D� * k k �� Source/Package/V2.pmnu �[��� PK ! ��4: 4: Y Deps.pmnu �[��� PK ! ���*�2 �2 �D Compression/FileHandle.pmnu �[��� PK ! ^��� �w Compression/Process.pmnu �[��� PK ! Ϋtӎ � b� Build/Info.pmnu �[��� PK ! ,� � -� Build/Env.pmnu �[��� PK ! rZ�_� � &� Build/Types.pmnu �[��� PK ! ԉ�&� � C� Interface/Storable.pmnu �[��� PK ! k�� � J� Dist/Files.pmnu �[��� PK ! ����Z Z 4� Vendor.pmnu �[��� PK ! ��jf" f" � Path.pmnu �[��� PK ! 5�� � d Control.pmnu �[��� PK ! b�;q� � ^5 Compression.pmnu �[��� PK ! ���Q@ Q@ �N Vendor/Debian.pmnu �[��� PK ! �{�� � � Vendor/Default.pmnu �[��� PK ! ��Ǯ � [� Vendor/Ubuntu.pmnu �[��� PK ! ��Q�P �P I� Changelog.pmnu �[��� PK ! O�eZ� � I Exit.pmnu �[��� PK ! �� �@- @- 7 Index.pmnu �[��� PK ! �4;�� � �I Deps/KnownFacts.pmnu �[��� PK ! H?DZ }` Deps/Multiple.pmnu �[��� PK ! bOF�� � �t Deps/OR.pmnu �[��� PK ! zN7$�G �G � Deps/Simple.pmnu �[��� PK ! �\�,� � �� Deps/Union.pmnu �[��� PK ! S�� g g � Deps/AND.pmnu �[��� PK ! /�UV UV �� Shlibs/SymbolFile.pmnu �[��� PK ! �l��� � <A Shlibs/Cppfilt.pmnu �[��� PK ! �'e-�D �D O Shlibs/Objdump.pmnu �[��� PK ! �=C�C7 C7 � Shlibs/Symbol.pmnu �[��� PK ! �<X�&; &; w� Arch.pmnu �[��� PK ! � �� � Shlibs.pmnu �[��� PK ! ��R � � % BuildProfiles.pmnu �[��� PK ! ��s �* Package.pmnu �[��� PK ! ��A�� � 30 ErrorHandling.pmnu �[��� PK ! }���u u !E OpenPGP.pmnu �[��� PK I I � �X
| ver. 1.1 | |
.
| PHP 8.4.18 | Ð“ÐµÐ½ÐµÑ€Ð°Ñ†Ð¸Ñ Ñтраницы: 0.04 |
proxy
|
phpinfo
|
ÐаÑтройка