diff options
author | Igor Pashev <pashev.igor@gmail.com> | 2017-11-19 13:53:03 +0300 |
---|---|---|
committer | Igor Pashev <pashev.igor@gmail.com> | 2017-11-19 14:16:14 +0300 |
commit | cae4c26c7eb2bd4cd8171a61f602e92796f8df46 (patch) | |
tree | 3adbad3ab7121e90403dfa8d155ec82a2706bb47 /scripts/Dpkg | |
parent | ad1014398394ec3f1d3c4ede34cd398625f4dbad (diff) | |
parent | 3ed0cc75a0113a5eda762b9a19448e78ce43097e (diff) | |
download | dpkg-cae4c26c7eb2bd4cd8171a61f602e92796f8df46.tar.gz |
Merge git://anonscm.debian.org/dpkg/dpkg
Diffstat (limited to 'scripts/Dpkg')
63 files changed, 3994 insertions, 1440 deletions
diff --git a/scripts/Dpkg/Arch.pm b/scripts/Dpkg/Arch.pm index a3114eadd..db6be6b2f 100644 --- a/scripts/Dpkg/Arch.pm +++ b/scripts/Dpkg/Arch.pm @@ -15,41 +15,93 @@ 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 = '0.01'; +our $VERSION = '1.02'; our @EXPORT_OK = qw( get_raw_build_arch get_raw_host_arch get_build_arch get_host_arch - get_gcc_host_gnu_type + get_host_gnu_type get_valid_arches debarch_eq debarch_is debarch_is_wildcard + debarch_is_illegal debarch_is_concerned - debarch_to_cpuattrs + debarch_to_abiattrs + debarch_to_cpubits debarch_to_gnutriplet - debarch_to_debtriplet + debarch_to_debtuple debarch_to_multiarch - debtriplet_to_debarch - debtriplet_to_gnutriplet + debarch_list_parse + debtuple_to_debarch + debtuple_to_gnutriplet gnutriplet_to_debarch - gnutriplet_to_debtriplet + 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 POSIX qw(:errno_h); +use List::Util qw(any); use Dpkg (); use Dpkg::Gettext; use Dpkg::ErrorHandling; -use Dpkg::Util qw(:list); -use Dpkg::BuildEnv; +use Dpkg::Build::Env; my (@cpu, @os); my (%cputable, %ostable); @@ -57,8 +109,19 @@ my (%cputable_re, %ostable_re); my (%cpubits, %cpuendian); my %abibits; -my %debtriplet_to_debarch; -my %debarch_to_debtriplet; +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() { @@ -71,6 +134,8 @@ sub get_raw_build_arch() # 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; @@ -78,76 +143,116 @@ sub get_raw_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::BuildEnv::get('DEB_BUILD_ARCH') || get_raw_build_arch(); + return Dpkg::Build::Env::get('DEB_BUILD_ARCH') || get_raw_build_arch(); } { - my $gcc_host_gnu_type; + my %cc_host_gnu_type; - sub get_gcc_host_gnu_type() + sub get_host_gnu_type() { - return $gcc_host_gnu_type if defined $gcc_host_gnu_type; + my $CC = $ENV{CC} || 'gcc'; - $gcc_host_gnu_type = qx(\${CC:-gcc} -dumpmachine); + 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) { - $gcc_host_gnu_type = ''; + $cc_host_gnu_type{$CC} = ''; } else { - chomp $gcc_host_gnu_type; + chomp $cc_host_gnu_type{$CC}; } - return $gcc_host_gnu_type; + return $cc_host_gnu_type{$CC}; } - sub get_raw_host_arch() + sub set_host_gnu_type { - state $host_arch; + my ($host_gnu_type) = @_; + my $CC = $ENV{CC} || 'gcc'; - return $host_arch if defined $host_arch; + $cc_host_gnu_type{$CC} = $host_gnu_type; + } +} - $gcc_host_gnu_type = get_gcc_host_gnu_type(); +=item $arch = get_raw_host_arch() - if ($gcc_host_gnu_type eq '') { - warning(g_("couldn't determine gcc system type, falling back to " . - 'default (native compilation)')); - } else { - my (@host_archtriplet) = gnutriplet_to_debtriplet($gcc_host_gnu_type); - $host_arch = debtriplet_to_debarch(@host_archtriplet); +Get the raw host Debian architecture, without taking into account variables +from the environment. - if (defined $host_arch) { - $gcc_host_gnu_type = debtriplet_to_gnutriplet(@host_archtriplet); - } else { - warning(g_('unknown gcc system type %s, falling back to ' . - 'default (native compilation)'), $gcc_host_gnu_type); - $gcc_host_gnu_type = ''; - } - } +=cut - if (!defined($host_arch)) { - # Switch to native compilation. - $host_arch = get_raw_build_arch(); - } +sub get_raw_host_arch() +{ + state $host_arch; - return $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::BuildEnv::get('DEB_HOST_ARCH') || get_raw_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() { - read_cputable(); - read_ostable(); + _load_cputable(); + _load_ostable(); my @arches; foreach my $os (@os) { foreach my $cpu (@cpu) { - my $arch = debtriplet_to_debarch(split(/-/, $os, 2), $cpu); + my $arch = debtuple_to_debarch(split(/-/, $os, 3), $cpu); push @arches, $arch if defined($arch); } } @@ -156,7 +261,7 @@ sub get_valid_arches() } my %table_loaded; -sub load_table +sub _load_table { my ($table, $loader) = @_; @@ -175,9 +280,9 @@ sub load_table $table_loaded{$table} = 1; } -sub read_cputable +sub _load_cputable { - load_table('cputable', sub { + _load_table('cputable', sub { if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) { $cputable{$1} = $2; $cputable_re{$1} = $3; @@ -188,9 +293,9 @@ sub read_cputable }); } -sub read_ostable +sub _load_ostable { - load_table('ostable', sub { + _load_table('ostable', sub { if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) { $ostable{$1} = $2; $ostable_re{$1} = $3; @@ -199,64 +304,65 @@ sub read_ostable }); } -sub abitable_load() +sub _load_abitable() { - load_table('abitable', sub { + _load_table('abitable', sub { if (m/^(?!\#)(\S+)\s+(\S+)/) { $abibits{$1} = $2; } }); } -sub read_triplettable() +sub _load_tupletable() { - read_cputable(); + _load_cputable(); - load_table('triplettable', sub { + _load_table('tupletable', sub { if (m/^(?!\#)(\S+)\s+(\S+)/) { - my $debtriplet = $1; + my $debtuple = $1; my $debarch = $2; - if ($debtriplet =~ /<cpu>/) { + if ($debtuple =~ /<cpu>/) { foreach my $_cpu (@cpu) { - (my $dt = $debtriplet) =~ s/<cpu>/$_cpu/; + (my $dt = $debtuple) =~ s/<cpu>/$_cpu/; (my $da = $debarch) =~ s/<cpu>/$_cpu/; - next if exists $debarch_to_debtriplet{$da} - or exists $debtriplet_to_debarch{$dt}; + next if exists $debarch_to_debtuple{$da} + or exists $debtuple_to_debarch{$dt}; - $debarch_to_debtriplet{$da} = $dt; - $debtriplet_to_debarch{$dt} = $da; + $debarch_to_debtuple{$da} = $dt; + $debtuple_to_debarch{$dt} = $da; } } else { - $debarch_to_debtriplet{$2} = $1; - $debtriplet_to_debarch{$1} = $2; + $debarch_to_debtuple{$2} = $1; + $debtuple_to_debarch{$1} = $2; } } }); } -sub debtriplet_to_gnutriplet(@) +sub debtuple_to_gnutriplet(@) { - my ($abi, $os, $cpu) = @_; + my ($abi, $libc, $os, $cpu) = @_; - read_cputable(); - read_ostable(); + _load_cputable(); + _load_ostable(); - return unless defined($abi) && defined($os) && defined($cpu) && - exists($cputable{$cpu}) && exists($ostable{"$abi-$os"}); - return join('-', $cputable{$cpu}, $ostable{"$abi-$os"}); + 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_debtriplet($) +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); - read_cputable(); - read_ostable(); + _load_cputable(); + _load_ostable(); my ($os, $cpu); @@ -275,9 +381,15 @@ sub gnutriplet_to_debtriplet($) } return if !defined($cpu) || !defined($os); - return (split(/-/, $os, 2), $cpu); + 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; @@ -292,6 +404,12 @@ sub gnutriplet_to_multiarch($) return "$cpu-$cdr"; } +=item $multiarch = debarch_to_multiarch($arch) + +Map a Debian architecture into a Debian multiarch triplet. + +=cut + sub debarch_to_multiarch($) { my $arch = shift; @@ -299,80 +417,103 @@ sub debarch_to_multiarch($) return gnutriplet_to_multiarch(debarch_to_gnutriplet($arch)); } -sub debtriplet_to_debarch(@) +sub debtuple_to_debarch(@) { - my ($abi, $os, $cpu) = @_; + my ($abi, $libc, $os, $cpu) = @_; - read_triplettable(); + _load_tupletable(); - if (!defined($abi) || !defined($os) || !defined($cpu)) { + if (!defined $abi || !defined $libc || !defined $os || !defined $cpu) { return; - } elsif (exists $debtriplet_to_debarch{"$abi-$os-$cpu"}) { - return $debtriplet_to_debarch{"$abi-$os-$cpu"}; + } elsif (exists $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}) { + return $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}; } else { return; } } -sub debarch_to_debtriplet($) +sub debarch_to_debtuple($) { my $arch = shift; - read_triplettable(); + return if not defined $arch; + + _load_tupletable(); if ($arch =~ /^linux-([^-]*)/) { # XXX: Might disappear in the future, not sure yet. $arch = $1; } - my $triplet = $debarch_to_debtriplet{$arch}; - - if (defined($triplet)) { - return split(/-/, $triplet, 3); + 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 debtriplet_to_gnutriplet(debarch_to_debtriplet($arch)); + 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 debtriplet_to_debarch(gnutriplet_to_debtriplet($gnu)); + return debtuple_to_debarch(gnutriplet_to_debtuple($gnu)); } -sub debwildcard_to_debtriplet($) +sub debwildcard_to_debtuple($) { my $arch = shift; - my @tuple = split /-/, $arch, 3; + my @tuple = split /-/, $arch, 4; if (any { $_ eq 'any' } @tuple) { - if (scalar @tuple == 3) { + if (scalar @tuple == 4) { return @tuple; - } elsif (scalar @tuple == 2) { + } elsif (scalar @tuple == 3) { return ('any', @tuple); + } elsif (scalar @tuple == 2) { + return ('any', 'any', @tuple); } else { - return ('any', 'any', 'any'); + return ('any', 'any', 'any', 'any'); } } else { - return debarch_to_debtriplet($arch); + return debarch_to_debtuple($arch); } } -sub debarch_to_cpuattrs($) +sub debarch_to_abiattrs($) { my $arch = shift; - my ($abi, $os, $cpu) = debarch_to_debtriplet($arch); + my ($abi, $libc, $os, $cpu) = debarch_to_debtuple($arch); if (defined($cpu)) { - abitable_load(); + _load_abitable(); return ($abibits{$abi} // $cpubits{$cpu}, $cpuendian{$cpu}); } else { @@ -380,53 +521,106 @@ sub debarch_to_cpuattrs($) } } +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_debtriplet($a); - my @b = debarch_to_debtriplet($b); + my @a = debarch_to_debtuple($a); + my @b = debarch_to_debtuple($b); - return 0 if scalar @a != 3 or scalar @b != 3; + 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]); + 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_debtriplet($real); - my @alias = debwildcard_to_debtriplet($alias); + my @real = debarch_to_debtuple($real); + my @alias = debwildcard_to_debtuple($alias); - return 0 if scalar @real != 3 or scalar @alias != 3; + 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[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 @triplet = debwildcard_to_debtriplet($arch); + my @tuple = debwildcard_to_debtuple($arch); - return 0 if scalar @triplet != 3; - return 1 if any { $_ eq 'any' } @triplet; + return 0 if scalar @tuple != 4; + return 1 if any { $_ eq 'any' } @tuple; return 0; } +=item $bool = debarch_is_illegal($arch) + +Validate an architecture name. + +=cut + +sub debarch_is_illegal +{ + my ($arch) = @_; + + return $arch !~ m/^!?[a-zA-Z0-9][a-zA-Z0-9-]*$/; +} + +=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) = @_; @@ -455,4 +649,47 @@ sub debarch_is_concerned return $seen_arch; } +=item @array = debarch_list_parse($arch_list, %options) + +Parse an architecture list. + +=cut + +sub debarch_list_parse +{ + my $arch_list = shift; + my @arch_list = split ' ', $arch_list; + + foreach my $arch (@arch_list) { + if (debarch_is_illegal($arch)) { + 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.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). diff --git a/scripts/Dpkg/BuildEnv.pm b/scripts/Dpkg/Build/Env.pm index 0de7844de..856d185fe 100644 --- a/scripts/Dpkg/BuildEnv.pm +++ b/scripts/Dpkg/Build/Env.pm @@ -13,7 +13,7 @@ # 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::BuildEnv; +package Dpkg::Build::Env; use strict; use warnings; @@ -27,18 +27,18 @@ my %env_accessed = (); =head1 NAME -Dpkg::BuildEnv - track build environment +Dpkg::Build::Env - track build environment =head1 DESCRIPTION -The Dpkg::BuildEnv module is used by dpkg-buildflags to track the build +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 $bf->set($varname, $value) +=item set($varname, $value) Update the build environment variable $varname with value $value. Record it as being accessed and modified. @@ -52,7 +52,7 @@ sub set { $ENV{$varname} = $value; } -=item $bf->get($varname) +=item get($varname) Get the build environment variable $varname value. Record it as being accessed. @@ -65,7 +65,7 @@ sub get { return $ENV{$varname}; } -=item $bf->has($varname) +=item has($varname) Return a boolean indicating whether the environment variable exists. Record it as being accessed. @@ -78,7 +78,7 @@ sub has { return exists $ENV{$varname}; } -=item my @list = $bf->list_accessed() +=item @list = list_accessed() Returns a list of all environment variables that have been accessed. @@ -89,7 +89,7 @@ sub list_accessed { return @list; } -=item my @list = $bf->list_modified() +=item @list = list_modified() Returns a list of all environment variables that have been modified. diff --git a/scripts/Dpkg/Build/Info.pm b/scripts/Dpkg/Build/Info.pm new file mode 100644 index 000000000..4935f0f08 --- /dev/null +++ b/scripts/Dpkg/Build/Info.pm @@ -0,0 +1,94 @@ +# 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.00'; +our @EXPORT_OK = qw( + get_build_env_whitelist +); + +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_whitelist() + +Get an array with the whitelist of environment variables that can affect +the build, but are still not privacy revealing. + +=cut + +my @env_whitelist = ( + # Toolchain. + qw(CC CPP CXX OBJC OBJCXX PC FC M2C AS LD AR RANLIB MAKE AWK LEX YACC), + # Toolchain flags. + qw(CFLAGS CPPFLAGS CXXFLAGS OBJCFLAGS OBJCXXFLAGS GCJFLAGS 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_whitelist { + return @env_whitelist; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.18.14) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Build/Types.pm b/scripts/Dpkg/Build/Types.pm new file mode 100644 index 000000000..45a81d3ba --- /dev/null +++ b/scripts/Dpkg/Build/Types.pm @@ -0,0 +1,251 @@ +# 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 + 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, +); + +=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_type, $build_option, %opts) + +Set the current build type from a list of 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 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; diff --git a/scripts/Dpkg/BuildFlags.pm b/scripts/Dpkg/BuildFlags.pm index 81ff49d27..0533b12b5 100644 --- a/scripts/Dpkg/BuildFlags.pm +++ b/scripts/Dpkg/BuildFlags.pm @@ -22,7 +22,7 @@ our $VERSION = '1.03'; use Dpkg (); use Dpkg::Gettext; -use Dpkg::BuildEnv; +use Dpkg::Build::Env; use Dpkg::BuildOptions; use Dpkg::ErrorHandling; use Dpkg::Vendor qw(run_vendor_hook); @@ -42,7 +42,7 @@ to query the same information. =over 4 -=item my $bf = Dpkg::BuildFlags->new() +=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. @@ -108,7 +108,7 @@ sub load_vendor_defaults { FCFLAGS => 0, LDFLAGS => 0, }; - # The Debian vendor hook will add hardening build flags + # The vendor hook will add the feature areas build flags. run_vendor_hook('update-buildflags', $self); } @@ -152,20 +152,20 @@ sub load_environment_config { foreach my $flag (keys %{$self->{flags}}) { my $envvar = 'DEB_' . $flag . '_SET'; - if (Dpkg::BuildEnv::has($envvar)) { - $self->set($flag, Dpkg::BuildEnv::get($envvar), 'env'); + if (Dpkg::Build::Env::has($envvar)) { + $self->set($flag, Dpkg::Build::Env::get($envvar), 'env'); } $envvar = 'DEB_' . $flag . '_STRIP'; - if (Dpkg::BuildEnv::has($envvar)) { - $self->strip($flag, Dpkg::BuildEnv::get($envvar), 'env'); + if (Dpkg::Build::Env::has($envvar)) { + $self->strip($flag, Dpkg::Build::Env::get($envvar), 'env'); } $envvar = 'DEB_' . $flag . '_APPEND'; - if (Dpkg::BuildEnv::has($envvar)) { - $self->append($flag, Dpkg::BuildEnv::get($envvar), 'env'); + if (Dpkg::Build::Env::has($envvar)) { + $self->append($flag, Dpkg::Build::Env::get($envvar), 'env'); } $envvar = 'DEB_' . $flag . '_PREPEND'; - if (Dpkg::BuildEnv::has($envvar)) { - $self->prepend($flag, Dpkg::BuildEnv::get($envvar), 'env'); + if (Dpkg::Build::Env::has($envvar)) { + $self->prepend($flag, Dpkg::Build::Env::get($envvar), 'env'); } } } @@ -182,20 +182,20 @@ sub load_maintainer_config { foreach my $flag (keys %{$self->{flags}}) { my $envvar = 'DEB_' . $flag . '_MAINT_SET'; - if (Dpkg::BuildEnv::has($envvar)) { - $self->set($flag, Dpkg::BuildEnv::get($envvar), undef, 1); + if (Dpkg::Build::Env::has($envvar)) { + $self->set($flag, Dpkg::Build::Env::get($envvar), undef, 1); } $envvar = 'DEB_' . $flag . '_MAINT_STRIP'; - if (Dpkg::BuildEnv::has($envvar)) { - $self->strip($flag, Dpkg::BuildEnv::get($envvar), undef, 1); + if (Dpkg::Build::Env::has($envvar)) { + $self->strip($flag, Dpkg::Build::Env::get($envvar), undef, 1); } $envvar = 'DEB_' . $flag . '_MAINT_APPEND'; - if (Dpkg::BuildEnv::has($envvar)) { - $self->append($flag, Dpkg::BuildEnv::get($envvar), undef, 1); + if (Dpkg::Build::Env::has($envvar)) { + $self->append($flag, Dpkg::Build::Env::get($envvar), undef, 1); } $envvar = 'DEB_' . $flag . '_MAINT_PREPEND'; - if (Dpkg::BuildEnv::has($envvar)) { - $self->prepend($flag, Dpkg::BuildEnv::get($envvar), undef, 1); + if (Dpkg::Build::Env::has($envvar)) { + $self->prepend($flag, Dpkg::Build::Env::get($envvar), undef, 1); } } } @@ -236,8 +236,8 @@ sub set { =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 area is -"hardening". +feature area has been enabled. The only currently known feature areas +are "future", "qa", "sanitize", "hardening" and "reproducible". =cut @@ -409,7 +409,8 @@ sub is_maintainer_modified { =item $bf->has_features($area) Returns true if the given area of features is known, and false otherwise. -The only currently recognized area is "hardening". +The only currently recognized feature areas are "future", "qa", "sanitize", +"hardening" and "reproducible". =cut @@ -429,7 +430,7 @@ sub has { return exists $self->{flags}{$key}; } -=item my @flags = $bf->list() +=item @flags = $bf->list() Returns the list of flags stored in the object. @@ -469,10 +470,6 @@ based on the package maintainer directives. Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org> - =cut 1; diff --git a/scripts/Dpkg/BuildOptions.pm b/scripts/Dpkg/BuildOptions.pm index 7e5ab0e73..057dfc1e3 100644 --- a/scripts/Dpkg/BuildOptions.pm +++ b/scripts/Dpkg/BuildOptions.pm @@ -1,5 +1,5 @@ # Copyright © 2007 Frank Lichtenheld <djpig@debian.org> -# Copyright © 2008, 2012-2015 Guillem Jover <guillem@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 @@ -20,11 +20,11 @@ package Dpkg::BuildOptions; use strict; use warnings; -our $VERSION = '1.01'; +our $VERSION = '1.02'; use Dpkg::Gettext; use Dpkg::ErrorHandling; -use Dpkg::BuildEnv; +use Dpkg::Build::Env; =encoding utf8 @@ -42,7 +42,7 @@ DEB_BUILD_MAINT_OPTIONS. =over 4 -=item my $bo = Dpkg::BuildOptions->new(%opts) +=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 @@ -60,7 +60,7 @@ sub new { envvar => $opts{envvar} // 'DEB_BUILD_OPTIONS', }; bless $self, $class; - $self->merge(Dpkg::BuildEnv::get($self->{envvar}), $self->{envvar}); + $self->merge(Dpkg::Build::Env::get($self->{envvar}), $self->{envvar}); return $self; } @@ -155,10 +155,47 @@ sub has { 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 of 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 optionnaly output that string to +assigned to an environment variable. Can optionally output that string to the given filehandle. =cut @@ -183,7 +220,7 @@ sub export { my ($self, $var) = @_; $var //= $self->{envvar}; my $content = $self->output(); - Dpkg::BuildEnv::set($var, $content); + Dpkg::Build::Env::set($var, $content); return $content; } @@ -191,6 +228,10 @@ sub export { =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. @@ -200,10 +241,6 @@ Thus add support for the "envvar" option at creation time. Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org> - =cut 1; diff --git a/scripts/Dpkg/BuildProfiles.pm b/scripts/Dpkg/BuildProfiles.pm index 9489f43d8..8684077f5 100644 --- a/scripts/Dpkg/BuildProfiles.pm +++ b/scripts/Dpkg/BuildProfiles.pm @@ -27,9 +27,9 @@ our @EXPORT_OK = qw( ); use Exporter qw(import); +use List::Util qw(any); -use Dpkg::Util qw(:list); -use Dpkg::BuildEnv; +use Dpkg::Build::Env; my $cache_profiles; my @build_profiles; @@ -49,7 +49,7 @@ profiles. =over 4 -=item my @profiles = get_build_profiles() +=item @profiles = get_build_profiles() Get an array with the currently active build profiles, taken from the environment variable B<DEB_BUILD_PROFILES>. @@ -59,8 +59,8 @@ the environment variable B<DEB_BUILD_PROFILES>. sub get_build_profiles { return @build_profiles if $cache_profiles; - if (Dpkg::BuildEnv::has('DEB_BUILD_PROFILES')) { - @build_profiles = split /\s+/, Dpkg::BuildEnv::get('DEB_BUILD_PROFILES'); + if (Dpkg::Build::Env::has('DEB_BUILD_PROFILES')) { + @build_profiles = split ' ', Dpkg::Build::Env::get('DEB_BUILD_PROFILES'); } $cache_profiles = 1; @@ -79,10 +79,10 @@ sub set_build_profiles { $cache_profiles = 1; @build_profiles = @profiles; - Dpkg::BuildEnv::set('DEB_BUILD_PROFILES', join ' ', @profiles); + Dpkg::Build::Env::set('DEB_BUILD_PROFILES', join ' ', @profiles); } -=item my @profiles = parse_build_profiles($string) +=item @profiles = parse_build_profiles($string) Parses a build profiles specification, into an array of array references. @@ -91,9 +91,9 @@ Parses a build profiles specification, into an array of array references. sub parse_build_profiles { my $string = shift; - $string =~ s/^\s*<(.*)>\s*$/$1/; + $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; - return map { [ split /\s+/ ] } split />\s+</, $string; + return map { [ split ' ' ] } split /\s*>\s+<\s*/, $string; } =item evaluate_restriction_formula(\@formula, \@profiles) diff --git a/scripts/Dpkg/Changelog.pm b/scripts/Dpkg/Changelog.pm index 6e61116d3..db8e3eb09 100644 --- a/scripts/Dpkg/Changelog.pm +++ b/scripts/Dpkg/Changelog.pm @@ -34,10 +34,12 @@ package Dpkg::Changelog; use strict; use warnings; -our $VERSION = '1.00'; +our $VERSION = '1.01'; + +use Carp; use Dpkg::Gettext; -use Dpkg::ErrorHandling qw(:DEFAULT report); +use Dpkg::ErrorHandling qw(:DEFAULT report REPORT_WARN); use Dpkg::Control; use Dpkg::Control::Changelog; use Dpkg::Control::Fields; @@ -54,7 +56,7 @@ use overload =over 4 -=item my $c = Dpkg::Changelog->new(%options) +=item $c = Dpkg::Changelog->new(%options) Creates a new changelog object. @@ -166,9 +168,9 @@ sub get_parse_errors { my $res = ''; foreach my $e (@{$self->{parse_errors}}) { if ($e->[3]) { - $res .= report(g_('warning'), g_("%s(l%s): %s\nLINE: %s"), @$e); + $res .= report(REPORT_WARN, g_("%s(l%s): %s\nLINE: %s"), @$e); } else { - $res .= report(g_('warning'), g_('%s(l%s): %s'), @$e); + $res .= report(REPORT_WARN, g_('%s(l%s): %s'), @$e); } } return $res; @@ -246,8 +248,10 @@ sub __sanity_check_range { # Handle non-existing versions my (%versions, @versions); foreach my $entry (@{$data}) { - $versions{$entry->get_version()->as_string()} = 1; - push @versions, $entry->get_version()->as_string(); + 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"), 'since'); @@ -471,52 +475,6 @@ sub output { return $str; } -=item my $control = $c->dpkg($range) - -Returns a Dpkg::Control::Changelog object representing the entries selected -by the optional range specifier (see L<"RANGE SELECTION"> for details). -Returns undef in no entries are matched. - -The following fields are contained in the object: - -=over 4 - -=item Source - -package name (in the first entry) - -=item Version - -packages' version (from first entry) - -=item Distribution - -target distribution (from first entry) - -=item Urgency - -urgency (highest of all printed entries) - -=item Maintainer - -person that created the (first) entry - -=item Date - -date of the (first) entry - -=item Closes - -bugs closed by the entry/entries, sorted by bug number - -=item Changes - -content of the the entry/entries - -=back - -=cut - our ( @URGENCIES, %URGENCIES ); BEGIN { @URGENCIES = qw(low medium high critical emergency); @@ -524,7 +482,7 @@ BEGIN { %URGENCIES = map { $_ => $i++ } @URGENCIES; } -sub dpkg { +sub _format_dpkg { my ($self, $range) = @_; my @data = $self->get_range($range) or return; @@ -537,6 +495,7 @@ sub dpkg { $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 @@ -578,21 +537,11 @@ sub dpkg { return $f; } -=item my @controls = $c->rfc822($range) - -Returns a Dpkg::Index containing Dpkg::Control::Changelog objects where -each object represents one entry in the changelog that is part of the -range requested (see L<"RANGE SELECTION"> for details). For the format of -such an object see the description of the L<"dpkg"> method (while ignoring -the remarks about which values are taken from the first entry). - -=cut - -sub rfc822 { +sub _format_rfc822 { my ($self, $range) = @_; my @data = $self->get_range($range) or return; - my $index = Dpkg::Index->new(type => CTRL_CHANGELOG); + my @ctrl; foreach my $entry (@data) { my $f = Dpkg::Control::Changelog->new(); @@ -602,6 +551,7 @@ sub rfc822 { $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 @@ -612,9 +562,129 @@ sub rfc822 { run_vendor_hook('post-process-changelog-entry', $f); - $index->add($f); + push @ctrl, $f; } - return $index; + + 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; + } +} + +=item $control = $c->dpkg($range) + +This is a deprecated alias for $c->format_range('dpkg', $range). + +=cut + +sub dpkg { + my ($self, $range) = @_; + + warnings::warnif('deprecated', + 'deprecated method, please use format_range("dpkg", $range) instead'); + + return $self->format_range('dpkg', $range); +} + +=item @controls = $c->rfc822($range) + +This is a deprecated alias for C<scalar c->format_range('rfc822', $range)>. + +=cut + +sub rfc822 { + my ($self, $range) = @_; + + warnings::warnif('deprecated', + 'deprecated method, please use format_range("rfc822", $range) instead'); + + return scalar $self->format_range('rfc822', $range); } =back @@ -677,17 +747,18 @@ wasn't given as well. 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 - C<{ since =E<gt> '2.0' }> 3.1, 3.0, 2.2 - C<{ until =E<gt> '2.0' }> 1.3, 1.2 - C<{ from =E<gt> '2.0' }> 3.1, 3.0, 2.2, 2.1, 2.0 - C<{ to =E<gt> '2.0' }> 2.0, 1.3, 1.2 - C<{ count =E<gt> 2 }> 3.1, 3.0 - C<{ count =E<gt> -2 }> 1.3, 1.2 - C<{ count =E<gt> 3, offset=E<gt> 2 }> 2.2, 2.1, 2.0 - C<{ count =E<gt> 2, offset=E<gt> -3 }> 2.0, 1.3 - C<{ count =E<gt> -2, offset=E<gt> 3 }> 3.0, 2.2 - C<{ count =E<gt> -2, offset=E<gt> -3 }> 2.2, 2.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 @@ -695,14 +766,17 @@ with only one of the options specified. =head1 CHANGES -=head2 Version 1.00 (dpkg 1.15.6) +=head2 Version 1.01 (dpkg 1.18.8) -Mark the module as public. +New method: $c->format_range(). + +Deprecated methods: $c->dpkg(), $c->rfc822(). -=head1 AUTHOR +New field Timestamp in output formats. -Frank Lichtenheld, E<lt>frank@lichtenheld.deE<gt> -Raphaël Hertzog, E<lt>hertzog@debian.orgE<gt> +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. =cut 1; diff --git a/scripts/Dpkg/Changelog/Debian.pm b/scripts/Dpkg/Changelog/Debian.pm index 943783d33..a44ac666c 100644 --- a/scripts/Dpkg/Changelog/Debian.pm +++ b/scripts/Dpkg/Changelog/Debian.pm @@ -1,7 +1,7 @@ # Copyright © 1996 Ian Jackson # Copyright © 2005 Frank Lichtenheld <frank@lichtenheld.de> # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> -# Copyright © 2012-2015 Guillem Jover <guillem@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 @@ -24,12 +24,11 @@ Dpkg::Changelog::Debian - parse Debian changelogs =head1 DESCRIPTION -Dpkg::Changelog::Debian parses Debian changelogs as described in the Debian -policy (version 3.6.2.1 at the time of this writing). See section -L<"SEE ALSO"> for locations where to find this definition. +Dpkg::Changelog::Debian parses Debian changelogs as described in +deb-changelog(5). The parser tries to ignore most cruft like # or /* */ style comments, -CVS comments, vim variables, emacs local variables and stuff from +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 @@ -58,14 +57,73 @@ use constant { 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 $c->parse($fh, $description) -Read the filehandle and parse a Debian changelog in it. Returns the number -of changelog entries that have been parsed with success. +Read the filehandle and parse a Debian 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. =cut @@ -98,7 +156,7 @@ sub parse { last if $self->abort_early(); } $entry->set_part('header', $_); - foreach my $error ($entry->check_header()) { + foreach my $error ($entry->parse_header()) { $self->parse_error($file, $., $error, $_); } $expect= START_CHANGES; @@ -106,21 +164,14 @@ sub parse { } elsif (m/^(?:;;\s*)?Local variables:/io) { last; # skip Emacs variables at end of file } elsif (m/^vim:/io) { - last; # skip vim variables at end of file + last; # skip Vim modelines at end of file } elsif (m/^\$\w+:.*\$/o) { - next; # skip stuff that look like a CVS keyword + 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/^(?:\w+\s+\w+\s+\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}\s+[\w\s]*\d{4})\s+(?:.*)\s+[<\(](?:.*)[\)>]/o - || m/^(?:\w+\s+\w+\s+\d{1,2},?\s*\d{4})\s+(?:.*)\s+[<\(](?:.*)[\)>]/o - || m/^(?:\w[-+0-9a-z.]*) \((?:[^\(\) \t]+)\)\;?/io - || m/^(?:[\w.+-]+)[- ](?:\S+) Debian (?:\S+)/io - || m/^Changes from version (?:.*) to (?:.*):/io - || m/^Changes for [\w.+-]+-[\w.+-]+:?\s*$/io - || m/^Old Changelog:\s*$/io - || m/^(?:\d+:)?\w[\w.+~-]*:?\s*$/o) { + } 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 @@ -135,7 +186,7 @@ sub parse { $entry->set_part('trailer', $_); $entry->extend_part('blank_after_changes', [ @blanklines ]); @blanklines = (); - foreach my $error ($entry->check_trailer()) { + foreach my $error ($entry->parse_trailer()) { $self->parse_error($file, $., $error, $_); } $expect = NEXT_OR_EOF; @@ -196,22 +247,14 @@ __END__ =back -=head1 SEE ALSO - -Dpkg::Changelog - -Description of the Debian changelog format in the Debian policy: -L<https://www.debian.org/doc/debian-policy/ch-source.html#s-dpkgchangelog>. - =head1 CHANGES =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. -=head1 AUTHORS +=head1 SEE ALSO -Frank Lichtenheld, E<lt>frank@lichtenheld.deE<gt> -Raphaël Hertzog, E<lt>hertzog@debian.orgE<gt> +Dpkg::Changelog =cut diff --git a/scripts/Dpkg/Changelog/Entry.pm b/scripts/Dpkg/Changelog/Entry.pm index 008764b8d..144dacb0f 100644 --- a/scripts/Dpkg/Changelog/Entry.pm +++ b/scripts/Dpkg/Changelog/Entry.pm @@ -18,7 +18,7 @@ package Dpkg::Changelog::Entry; use strict; use warnings; -our $VERSION = '1.00'; +our $VERSION = '1.01'; use Carp; @@ -47,7 +47,7 @@ trailer line. Blank lines can be between those kind of lines. =over 4 -=item my $entry = Dpkg::Changelog::Entry->new() +=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. @@ -70,7 +70,7 @@ sub new { return $self; } -=item my $str = $entry->output() +=item $str = $entry->output() =item "$entry" @@ -210,7 +210,7 @@ sub normalize { } } -=item my $src = $entry->get_source() +=item $src = $entry->get_source() Return the name of the source package associated to the changelog entry. @@ -220,7 +220,7 @@ sub get_source { return; } -=item my $ver = $entry->get_version() +=item $ver = $entry->get_version() Return the version associated to the changelog entry. @@ -230,7 +230,7 @@ sub get_version { return; } -=item my @dists = $entry->get_distributions() +=item @dists = $entry->get_distributions() Return a list of target distributions for this version. @@ -261,7 +261,7 @@ sub get_urgency { return; } -=item my $maint = $entry->get_maintainer() +=item $maint = $entry->get_maintainer() Return the string identifying the person who signed this changelog entry. @@ -271,7 +271,7 @@ sub get_maintainer { return; } -=item my $time = $entry->get_timestamp() +=item $time = $entry->get_timestamp() Return the timestamp of the changelog entry. @@ -281,7 +281,19 @@ sub get_timestamp { return; } -=item my $str = $entry->get_dpkg_changes() +=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>. @@ -299,13 +311,13 @@ sub get_dpkg_changes { =head1 CHANGES -=head2 Version 1.00 (dpkg 1.15.6) +=head2 Version 1.01 (dpkg 1.18.8) -Mark the module as public. +New method: $entry->get_timepiece(). -=head1 AUTHOR +=head2 Version 1.00 (dpkg 1.15.6) -Raphaël Hertzog <hertzog@debian.org>. +Mark the module as public. =cut diff --git a/scripts/Dpkg/Changelog/Entry/Debian.pm b/scripts/Dpkg/Changelog/Entry/Debian.pm index 577788b4e..3d1888638 100644 --- a/scripts/Dpkg/Changelog/Entry/Debian.pm +++ b/scripts/Dpkg/Changelog/Entry/Debian.pm @@ -19,7 +19,7 @@ package Dpkg::Changelog::Entry::Debian; use strict; use warnings; -our $VERSION = '1.01'; +our $VERSION = '1.03'; our @EXPORT_OK = qw( $regex_header $regex_trailer @@ -29,7 +29,7 @@ our @EXPORT_OK = qw( ); use Exporter qw(import); -use Date::Parse; +use Time::Piece; use Dpkg::Gettext; use Dpkg::Control::Fields; @@ -60,11 +60,45 @@ 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). -our $regex_header = qr/^(\w$name_chars*) \(([^\(\) \t]+)\)((?:\s+$name_chars+)+)\;(.*?)\s*$/i; +our $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). -our $regex_trailer = qr/^ \-\- (.*) <(.*)>( ?)((\w+\,\s*)?\d{1,2}\s+\w+\s+\d{4}\s+\d{1,2}:\d\d:\d\d\s+[-+]\d{4}(\s+\([^\\\(\)]\))?)\s*$/o; +# some blanks ($3) and the timestamp ($4), which is decomposed into +# day of week ($6), date-time ($7) and this into month name ($8). +our $regex_trailer = qr< + ^ + \ \-\- # 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 = map { $_ => 1 } qw( + Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec +); +my %month_name = map { $_ => } qw( + January February March April May June July + August September October November December +); ## use critic @@ -72,11 +106,11 @@ our $regex_trailer = qr/^ \-\- (.*) <(.*)>( ?)((\w+\,\s*)?\d{1,2}\s+\w+\s+\d{4} =over 4 -=item my @items = $entry->get_change_items() +=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 "[ Raphaël Hertzog ]" is treated like an item of its +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). @@ -109,9 +143,9 @@ sub get_change_items { return @items; } -=item my @errors = $entry->check_header() +=item @errors = $entry->parse_header() -=item my @errors = $entry->check_trailer() +=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 @@ -119,23 +153,36 @@ have been found. =cut -sub check_header { +sub parse_header { my $self = shift; my @errors; if (defined($self->{header}) and $self->{header} =~ $regex_header) { - my ($version, $options) = ($2, $4); + $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 %optdone; + 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 ($optdone{$k}) { + if (exists $f->{$k}) { push @errors, sprintf(g_('repeated key-value %s'), $k); + } else { + $f->{$k} = $v; } - $optdone{$k} = 1; if ($k eq 'Urgency') { push @errors, sprintf(g_('badly formatted urgency value: %s'), $v) unless ($v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i); @@ -147,32 +194,87 @@ sub check_header { push @errors, sprintf(g_('unknown key-value %s'), $k); } } - my ($ok, $msg) = version_check($version); - unless ($ok) { - push @errors, sprintf(g_("version '%s' is invalid: %s"), $version, $msg); - } + $self->{header_fields} = $f; } else { push @errors, g_("the header doesn't match the expected regex"); } return @errors; } -sub check_trailer { +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'); } - unless (defined str2time($4)) { - push @errors, sprintf(g_("couldn't parse date %s"), $4); + + # 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 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-comformant date '%s'"), $7); + }; + $self->{trailer_timestamp_date} = $4; } else { push @errors, g_("the trailer doesn't match the expected regex"); } return @errors; } +=item $entry->check_header() + +Obsolete method. Use parse_header() instead. + +=cut + +sub check_header { + my $self = shift; + + warnings::warnif('deprecated', + 'obsolete check_header(), use parse_header() instead'); + + return $self->parse_header(); +} + +=item $entry->check_trailer() + +Obsolete method. Use parse_trailer() instead. + +=cut + +sub check_trailer { + my $self = shift; + + warnings::warnif('deprecated', + 'obsolete check_trailer(), use parse_trailer() instead'); + + return $self->parse_header(); +} + =item $entry->normalize() Normalize the content. Strip whitespaces at end of lines, use a single @@ -186,53 +288,77 @@ sub 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; - if (defined($self->{header}) and $self->{header} =~ $regex_header) { - return $1; - } - return; + + return $self->{header_source}; } +=item $ver = $entry->get_version() + +Return the version associated to the changelog entry. + +=cut + sub get_version { my $self = shift; - if (defined($self->{header}) and $self->{header} =~ $regex_header) { - return Dpkg::Version->new($2); - } - return; + + 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}) and $self->{header} =~ $regex_header) { - my $value = $3; - $value =~ s/^\s+//; - my @dists = split(/\s+/, $value); - return @dists if wantarray; - return $dists[0]; + + 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 = Dpkg::Control::Changelog->new(); - if (defined($self->{header}) and $self->{header} =~ $regex_header) { - my $options = $4; - $options =~ s/^\s+//; - foreach my $opt (split(/\s*,\s*/, $options)) { - if ($opt =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i) { - $f->{$1} = $2; - } - } + 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(); @@ -243,20 +369,42 @@ sub get_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; - if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) { - return "$1 <$2>"; - } - return; + + return $self->{trailer_maintainer}; } +=item $time = $entry->get_timestamp() + +Return the timestamp of the changelog entry. + +=cut + sub get_timestamp { my $self = shift; - if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) { - return $4; - } - return; + + 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 @@ -265,7 +413,7 @@ sub get_timestamp { =over 4 -=item my $bool = match_header($line) +=item $bool = match_header($line) Checks if the line matches a valid changelog header line. @@ -277,7 +425,7 @@ sub match_header { return $line =~ /$regex_header/; } -=item my $bool = match_trailer($line) +=item $bool = match_trailer($line) Checks if the line matches a valid changelog trailing line. @@ -289,7 +437,7 @@ sub match_trailer { return $line =~ /$regex_trailer/; } -=item my @closed_bugs = find_closes($changes) +=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 @@ -301,8 +449,11 @@ sub find_closes { my $changes = shift; my %closes; - while ($changes && - ($changes =~ /closes:\s*(?:bug)?\#?\s?\d+(?:,\s*(?:bug)?\#?\s?\d+)*/pig)) { + while ($changes && ($changes =~ m{ + closes:\s* + (?:bug)?\#?\s?\d+ + (?:,\s*(?:bug)?\#?\s?\d+)* + }pigx)) { $closes{$_} = 1 foreach (${^MATCH} =~ /\#?\s?(\d+)/g); } @@ -314,6 +465,16 @@ sub find_closes { =head1 CHANGES +=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() @@ -324,10 +485,6 @@ Deprecated variables: $regex_header, $regex_trailer Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Changelog/Parse.pm b/scripts/Dpkg/Changelog/Parse.pm index 58772e6c6..e107dcf6d 100644 --- a/scripts/Dpkg/Changelog/Parse.pm +++ b/scripts/Dpkg/Changelog/Parse.pm @@ -23,8 +23,8 @@ Dpkg::Changelog::Parse - generic changelog parser for dpkg-parsechangelog =head1 DESCRIPTION -This module provides a single function changelog_parse() which reproduces -all the features of dpkg-parsechangelog. +This module provides a set of functions which reproduce all the features +of dpkg-parsechangelog. =cut @@ -33,140 +33,192 @@ package Dpkg::Changelog::Parse; use strict; use warnings; -our $VERSION = '1.00'; +our $VERSION = '1.03'; our @EXPORT = qw( + changelog_parse_debian + changelog_parse_plugin 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, '-|', 'tail', '-n', '40', $file + or syserr(g_('cannot create pipe for %s'), 'tail'); + while (<$format_fh>) { + $format = $1 if m/\schangelog-format:\s+([0-9a-z]+)\W/; + } + close $format_fh or subprocerr(g_('tail of %s'), $file); + } + + return $format; +} + =head1 FUNCTIONS =over 4 -=item my $fields = changelog_parse(%opt) +=item $fields = changelog_parse_debian(%opt) + +This function is deprecated, use changelog_parse() instead, with the changelog +format set to "debian". + +=cut + +sub changelog_parse_debian { + my (%options) = @_; + + warnings::warnif('deprecated', + 'deprecated function changelog_parse_debian, use changelog_parse instead'); + + # Force the plugin to be debian. + $options{changelogformat} = 'debian'; + + return _changelog_parse(%options); +} + +=item $fields = changelog_parse_plugin(%opt) + +This function is deprecated, use changelog_parse() instead. + +=cut + +sub changelog_parse_plugin { + my (%options) = @_; + + warnings::warnif('deprecated', + 'deprecated function changelog_parse_plugin, use changelog_parse instead'); + + return _changelog_parse(%options); +} -This function will parse a changelog. In list context, it return as many -Dpkg::Control object as the parser did output. In scalar context, it will -return only the first one. If the parser didn't return any data, it will -return an empty in list context or undef on scalar context. If the parser -failed, it will die. +=item $fields = changelog_parse(%opt) -The parsing itself is done by an external program (searched in the -following list of directories: $opt{libdir}, -F</usr/local/lib/dpkg/parsechangelog>, F</usr/lib/dpkg/parsechangelog>) That -program is named according to the format that it's able to parse. By -default it's either "debian" or the format name lookep 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}. The program expects the content of the -changelog file on its standard input. +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. The changelog file that is parsed is F<debian/changelog> by default but it -can be overridden with $opt{file}. +can be overridden with $opt{file}. The default output format is "dpkg" but +it can be overridden with $opt{format}. -All the other keys in %opt are forwarded as parameter to the external -parser. If the key starts with "-", it's passed as is. If not, it's passed -as "--<key>". If the value of the corresponding hash entry is defined, then -it's passed as the parameter that follows. +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 { +sub _changelog_parse { my (%options) = @_; - my @parserpath = ('/usr/local/lib/dpkg/parsechangelog', - "$Dpkg::LIBDIR/parsechangelog", - '/usr/lib/dpkg/parsechangelog'); - my $format = 'debian'; - my $force = 0; - # Extract and remove options that do not concern the changelog parser - # itself (and that we shouldn't forward) + # Setup and sanity checks. if (exists $options{libdir}) { - unshift @parserpath, $options{libdir}; - delete $options{libdir}; - } - if (exists $options{changelogformat}) { - $format = $options{changelogformat}; - delete $options{changelogformat}; - $force = 1; + warnings::warnif('deprecated', + 'obsolete libdir option, changelog parsers are now perl modules'); } - # Set a default filename $options{file} //= 'debian/changelog'; - my $changelogfile = $options{file}; - - # Extract the format from the changelog file if possible - unless ($force or ($changelogfile eq '-')) { - local $_; - - open(my $format_fh, '-|', 'tail', '-n', '40', $changelogfile) - or syserr(g_('cannot create pipe for %s'), 'tail'); - while (<$format_fh>) { - $format = $1 if m/\schangelog-format:\s+([0-9a-z]+)\W/; - } - close($format_fh) or subprocerr(g_('tail of %s'), $changelogfile); + $options{label} //= $options{file}; + $options{changelogformat} //= _changelog_detect_format($options{file}); + $options{format} //= 'dpkg'; + $options{compression} //= $options{file} ne 'debian/changelog'; + + my @range_opts = qw(since until from to offset count all); + $options{all} = 1 if exists $options{all}; + if (none { defined $options{$_} } @range_opts) { + $options{count} = 1; } - - # Find the right changelog parser - my $parser; - foreach my $dir (@parserpath) { - my $candidate = "$dir/$format"; - next if not -e $candidate; - if (-x _) { - $parser = $candidate; - last; - } else { - warning(g_('format parser %s not executable'), $candidate); - } - } - error(g_('changelog format %s is unknown'), $format) if not defined $parser; - - # Create the arguments for the changelog parser - my @exec = ($parser, "-l$changelogfile"); - foreach my $option (keys %options) { - if ($option =~ m/^-/) { - # Options passed untouched - push @exec, $option; - } else { - # Non-options are mapped to long options - push @exec, "--$option"; - } - push @exec, $options{$option} if defined $options{$option}; + my $range; + foreach my $opt (@range_opts) { + $range->{$opt} = $options{$opt} if exists $options{$opt}; } - # Fork and call the parser - my $pid = open(my $parser_fh, '-|'); - syserr(g_('cannot fork for %s'), $parser) unless defined $pid; - if (not $pid) { - exec @exec or syserr(g_('cannot execute format parser: %s'), $parser); + # 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 $@; + $changes->set_options(reportfile => $options{label}, 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}); } - # Get the output into several Dpkg::Control objects - my (@res, $fields); - while (1) { - $fields = Dpkg::Control::Changelog->new(); - last unless $fields->parse($parser_fh, g_('output of changelog parser')); - push @res, $fields; - } - close($parser_fh) or subprocerr(g_('changelog parser %s'), $parser); if (wantarray) { - return @res; + return @res; } else { - return $res[0] if (@res); - return; + return $res[0] if @res; + return; } } +sub changelog_parse { + my (%options) = @_; + + if (exists $options{forceplugin}) { + warnings::warnif('deprecated', 'obsolete forceplugin option'); + } + + return _changelog_parse(%options); +} + =back =head1 CHANGES +=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. diff --git a/scripts/Dpkg/Checksums.pm b/scripts/Dpkg/Checksums.pm index 93eda0da2..1237e8b89 100644 --- a/scripts/Dpkg/Checksums.pm +++ b/scripts/Dpkg/Checksums.pm @@ -20,7 +20,7 @@ package Dpkg::Checksums; use strict; use warnings; -our $VERSION = '1.02'; +our $VERSION = '1.03'; our @EXPORT = qw( checksums_is_supported checksums_get_list @@ -28,7 +28,6 @@ our @EXPORT = qw( ); use Exporter qw(import); -use Carp; use Digest; use Dpkg::Gettext; @@ -56,14 +55,17 @@ 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, }, }; @@ -95,14 +97,19 @@ sub checksums_is_supported($) { 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) and "regex" for the regular expression describing the common -string representation of the checksum. +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) = @_; - carp 'obsolete checksums program property' if $property eq 'program'; + + if ($property eq 'program') { + warnings::warnif('deprecated', 'obsolete checksums program property'); + } + return unless checksums_is_supported($alg); return $CHECKSUMS->{lc($alg)}{$property}; } @@ -113,7 +120,7 @@ sub checksums_get_property($$) { =over 4 -=item my $ck = Dpkg::Checksums->new() +=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. @@ -148,9 +155,9 @@ sub reset { =item $ck->add_from_file($filename, %opts) -Add 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" +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. @@ -335,6 +342,23 @@ sub get_size { 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 @@ -376,9 +400,15 @@ sub export_to_control { =head1 CHANGES +=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 carp() and +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 @@ -395,10 +425,6 @@ $ck->add_from_control(). Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Compression.pm b/scripts/Dpkg/Compression.pm index b42634288..3dbc4adf0 100644 --- a/scripts/Dpkg/Compression.pm +++ b/scripts/Dpkg/Compression.pm @@ -35,6 +35,7 @@ our @EXPORT = qw( ); use Exporter qw(import); +use Config; use Dpkg::ErrorHandling; use Dpkg::Gettext; @@ -47,7 +48,7 @@ Dpkg::Compression - simple database of available compression methods =head1 DESCRIPTION -This modules provides a few public funcions and a public regex to +This modules provides a few public functions and a public regex to interact with the set of supported compression methods. =cut @@ -55,7 +56,7 @@ interact with the set of supported compression methods. my $COMP = { gzip => { file_ext => 'gz', - comp_prog => [ 'gzip', '--no-name', '--rsyncable' ], + comp_prog => [ 'gzip', '--no-name' ], decomp_prog => [ 'gunzip' ], default_level => 9, }, @@ -79,6 +80,24 @@ my $COMP = { }, }; +# +# XXX: The gzip package in Debian at some point acquired a Debian-specific +# --rsyncable option via a vendor patch. Which is not present in most of the +# major distributions, dpkg downstream systems, nor gzip upstream, who have +# stated they will most probably not accept it because people should be using +# pigz instead. +# +# This option should have never been accepted in dpkg, ever. But removing it +# now would probably cause demands for tarring and feathering. In addition +# we cannot use the Dpkg::Vendor logic because that would cause circular +# module dependencies. The whole affair is pretty disgusting really. +# +# Check the perl Config to discern Debian and hopefully derivatives too. +# +if ($Config{cf_by} eq 'Debian Project') { + push @{$COMP->{gzip}->{comp_prog}}, '--rsyncable'; +} + # XXX: Backwards compatibility, stop exporting on VERSION 2.00. ## no critic (Variables::ProhibitPackageVars) our $default_compression = 'xz'; @@ -92,7 +111,7 @@ our $compression_re_file_ext = qr/(?:$regex)/; =over 4 -=item my @list = compression_get_list() +=item @list = compression_get_list() Returns a list of supported compression methods (sorted alphabetically). @@ -152,7 +171,7 @@ sub compression_guess_from_filename { return; } -=item my $regex = compression_get_file_extension_regex() +=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. @@ -163,7 +182,7 @@ sub compression_get_file_extension_regex { return $compression_re_file_ext; } -=item my $comp = compression_get_default() +=item $comp = compression_get_default() Return the default compression method. It is "xz" unless C<compression_set_default> has been used to change it. @@ -186,7 +205,7 @@ sub compression_set_default { $default_compression = $method; } -=item my $level = compression_get_default_level() +=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 @@ -246,10 +265,6 @@ Default compression level is not global any more, it is per compressor type. Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Compression/FileHandle.pm b/scripts/Dpkg/Compression/FileHandle.pm index 3f83545c3..23b39841a 100644 --- a/scripts/Dpkg/Compression/FileHandle.pm +++ b/scripts/Dpkg/Compression/FileHandle.pm @@ -21,7 +21,6 @@ use warnings; our $VERSION = '1.01'; -use POSIX qw(:signal_h :sys_wait_h); use Carp; use Dpkg::Compression; @@ -29,7 +28,7 @@ use Dpkg::Compression::Process; use Dpkg::Gettext; use Dpkg::ErrorHandling; -use parent qw(FileHandle Tie::Handle); +use parent qw(IO::File Tie::Handle); # Useful reference to understand some kludges required to # have the object behave like a filehandle @@ -45,6 +44,8 @@ Dpkg::Compression::FileHandle - object dealing transparently with file compressi use Dpkg::Compression::FileHandle; + my ($fh, @lines); + $fh = Dpkg::Compression::FileHandle->new(filename => 'sample.gz'); print $fh "Something\n"; close $fh; @@ -60,17 +61,17 @@ Dpkg::Compression::FileHandle - object dealing transparently with file compressi $fh->close(); $fh = Dpkg::Compression::FileHandle->new(filename => 'sample.gz'); - my @lines = <$fh>; + @lines = <$fh>; close $fh; $fh = Dpkg::Compression::FileHandle->new(); open($fh, '<', 'sample.bz2'); - my @lines = <$fh>; + @lines = <$fh>; close $fh; $fh = Dpkg::Compression::FileHandle->new(); $fh->open('sample.xz', 'r'); - my @lines = $fh->getlines(); + @lines = $fh->getlines(); $fh->close(); =head1 DESCRIPTION @@ -101,7 +102,7 @@ and you can't seek on a pipe. =head1 FileHandle METHODS -The object inherits from FileHandle so all methods that work on this +The object inherits from IO::File so all methods that work on this object should work for Dpkg::Compression::FileHandle too. There may be exceptions though. @@ -109,7 +110,7 @@ may be exceptions though. =over 4 -=item my $fh = Dpkg::Compression::FileHandle->new(%opts) +=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 @@ -124,10 +125,10 @@ obviously incompatible with automatic detection of the compression method. sub new { my ($this, %args) = @_; my $class = ref($this) || $this; - my $self = FileHandle->new(); + 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; + tie *$self, $class, $self; ## no critic (Miscellanea::ProhibitTies) bless $self, $class; # Initializations *$self->{compression} = 'auto'; @@ -169,9 +170,9 @@ sub ensure_open { delete $opts{to_file}; if ($mode eq 'w') { - $self->open_for_write(%opts); + $self->_open_for_write(%opts); } elsif ($mode eq 'r') { - $self->open_for_read(%opts); + $self->_open_for_read(%opts); } else { croak "invalid mode in ensure_open: $mode"; } @@ -211,9 +212,9 @@ sub OPEN { my ($mode, $filename) = @_; $self->set_filename($filename); if ($mode eq '>') { - $self->open_for_write(); + $self->_open_for_write(); } elsif ($mode eq '<') { - $self->open_for_read(); + $self->_open_for_read(); } else { croak 'Dpkg::Compression::FileHandle does not support ' . "open() mode $mode"; @@ -233,7 +234,7 @@ sub CLOSE { } else { $ret = 0; } - $self->cleanup(); + $self->_cleanup(); return $ret; } @@ -325,7 +326,7 @@ sub set_filename { } } -=item my $file = $fh->get_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 @@ -374,7 +375,7 @@ sub use_compression { return $comp; } -=item my $real_fh = $fh->get_filehandle() +=item $real_fh = $fh->get_filehandle() Returns the real underlying filehandle. Useful if you want to pass it along in a derived object. @@ -388,7 +389,7 @@ sub get_filehandle { ## INTERNAL METHODS -sub open_for_write { +sub _open_for_write { my ($self, %opts) = @_; my $filehandle; @@ -406,7 +407,7 @@ sub open_for_write { *$self->{file} = $filehandle; } -sub open_for_read { +sub _open_for_read { my ($self, %opts) = @_; my $filehandle; @@ -425,12 +426,14 @@ sub open_for_read { *$self->{file} = $filehandle; } -sub cleanup { +sub _cleanup { my $self = shift; my $cmdline = *$self->{compressor}{cmdline} // ''; *$self->{compressor}->wait_end_process(nocheck => *$self->{allow_sigpipe}); if (*$self->{allow_sigpipe}) { - unless (($? == 0) || (WIFSIGNALED($?) && (WTERMSIG($?) == SIGPIPE))) { + require POSIX; + unless (($? == 0) || (POSIX::WIFSIGNALED($?) && + (POSIX::WTERMSIG($?) == POSIX::SIGPIPE()))) { subprocerr($cmdline); } *$self->{allow_sigpipe} = 0; @@ -466,9 +469,5 @@ New argument: $fh->ensure_open() accepts an %opts argument. Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org> - =cut 1; diff --git a/scripts/Dpkg/Compression/Process.pm b/scripts/Dpkg/Compression/Process.pm index cc1fe4db2..9b733cc74 100644 --- a/scripts/Dpkg/Compression/Process.pm +++ b/scripts/Dpkg/Compression/Process.pm @@ -42,7 +42,7 @@ compression/decompression processes. =over 4 -=item my $proc = Dpkg::Compression::Process->new(%opts) +=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). @@ -90,9 +90,9 @@ sub set_compression_level { $self->{compression_level} = $level; } -=item my @exec = $proc->get_compress_cmdline() +=item @exec = $proc->get_compress_cmdline() -=item my @exec = $proc->get_uncompress_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 @@ -206,10 +206,6 @@ sub wait_end_process { Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Conf.pm b/scripts/Dpkg/Conf.pm index 00cee2382..ca98cd3a7 100644 --- a/scripts/Dpkg/Conf.pm +++ b/scripts/Dpkg/Conf.pm @@ -18,7 +18,9 @@ package Dpkg::Conf; use strict; use warnings; -our $VERSION = '1.01'; +our $VERSION = '1.03'; + +use Carp; use Dpkg::Gettext; use Dpkg::ErrorHandling; @@ -38,13 +40,13 @@ Dpkg::Conf - parse dpkg configuration files =head1 DESCRIPTION The Dpkg::Conf object can be used to read options from a configuration -file. It can exports an array that can then be parsed exactly like @ARGV. +file. It can export an array that can then be parsed exactly like @ARGV. =head1 METHODS =over 4 -=item my $conf = Dpkg::Conf->new(%opts) +=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 @@ -79,16 +81,91 @@ Returns the list of options that can be parsed like @ARGV. sub get_options { my $self = shift; + return @{$self->{options}}; } +=item get() + +=item set() + +Obsolete functions, use get_options() instead. They will croak. + +=cut + +sub get { + croak 'obsolete function, use get_options instead'; +} + +sub set { + croak 'obsolete function, use get_options instead'; +} + =item $conf->load($file) Read options from a file. Return the number of options parsed. +=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. Return the number of options parsed. +Parse options from a file handle. When called multiple times, the parsed +options are accumulated. + +Return the number of options parsed. =cut @@ -126,12 +203,10 @@ sub parse { return $count; } -=item $conf->filter(remove => $rmfunc) - -=item $conf->filter(keep => $keepfunc) +=item $conf->filter(%opts) Filter the list of options, either removing or keeping all those that -return true when &$rmfunc($option) or &keepfunc($option) is called. +return true when $opts{remove}->($option) or $opts{keep}->($option) is called. =cut @@ -140,7 +215,9 @@ sub filter { my $remove = $opts{remove} // sub { 0 }; my $keep = $opts{keep} // sub { 1 }; - @{$self->{options}} = grep { not &$remove($_) and &$keep($_) } + croak 'obsolete option format_argv' if exists $opts{format_argv}; + + @{$self->{options}} = grep { not $remove->($_) and $keep->($_) } @{$self->{options}}; } @@ -164,9 +241,7 @@ sub output { my $ret = ''; foreach my $opt ($self->get_options()) { $opt =~ s/^--//; - if ($opt =~ s/^([^=]+)=/$1 = "/) { - $opt .= '"'; - } + $opt =~ s/^([^=]+)=(.*)$/$1 = "$2"/; $opt .= "\n"; print { $fh } $opt if defined $fh; $ret .= $opt; @@ -178,6 +253,21 @@ sub output { =head1 CHANGES +=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() @@ -186,10 +276,6 @@ New method: $conf->filter() Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Control.pm b/scripts/Dpkg/Control.pm index 7094f3518..f41f250d5 100644 --- a/scripts/Dpkg/Control.pm +++ b/scripts/Dpkg/Control.pm @@ -18,19 +18,25 @@ package Dpkg::Control; use strict; use warnings; -our $VERSION = '1.00'; +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); @@ -76,6 +82,10 @@ a Debian source package. 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 @@ -95,6 +105,10 @@ Corresponds to a .dsc file of a Debian source package. 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. @@ -111,6 +125,25 @@ Corresponds to an entry in dpkg's F<status> file ($Dpkg::ADMINDIR/status). 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 @@ -120,7 +153,7 @@ are either new or overridden with a different behaviour. =over 4 -=item my $c = Dpkg::Control->new(%opts) +=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. @@ -142,10 +175,10 @@ sub new { 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 and CTRL_FILE_CHANGES 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. +"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). @@ -156,7 +189,7 @@ sub set_options { my ($self, %opts) = @_; if (exists $opts{type}) { my $t = $opts{type}; - $$self->{allow_pgp} = ($t & (CTRL_PKG_SRC | CTRL_FILE_CHANGES)) ? 1 : 0; + $$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'); @@ -164,6 +197,16 @@ sub set_options { $$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) { @@ -172,6 +215,8 @@ sub set_options { $$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) { @@ -202,13 +247,22 @@ sub get_type { =head1 CHANGES -=head2 Version 1.00 (dpkg 1.15.6) +=head2 Version 1.03 (dpkg 1.18.11) -Mark the module as public. +New type: CTRL_FILE_BUILDINFO. + +=head2 Version 1.02 (dpkg 1.18.8) -=head1 AUTHOR +New type: CTRL_TESTS. -Raphaël Hertzog <hertzog@debian.org>. +=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 diff --git a/scripts/Dpkg/Control/Changelog.pm b/scripts/Dpkg/Control/Changelog.pm index a73ccbeb3..1f65127c4 100644 --- a/scripts/Dpkg/Control/Changelog.pm +++ b/scripts/Dpkg/Control/Changelog.pm @@ -60,10 +60,6 @@ sub new { Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Control/Fields.pm b/scripts/Dpkg/Control/Fields.pm index cd0347c7b..4a584e413 100644 --- a/scripts/Dpkg/Control/Fields.pm +++ b/scripts/Dpkg/Control/Fields.pm @@ -61,10 +61,6 @@ inherited from Dpkg::Control::FieldsCore. Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Control/FieldsCore.pm b/scripts/Dpkg/Control/FieldsCore.pm index 82e1a7285..b100366e1 100644 --- a/scripts/Dpkg/Control/FieldsCore.pm +++ b/scripts/Dpkg/Control/FieldsCore.pm @@ -44,12 +44,12 @@ use Exporter qw(import); use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Control::Types; -use Dpkg::Checksums; 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 { @@ -64,341 +64,614 @@ use constant { # 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' => { - allowed => (ALL_PKG | ALL_SRC | CTRL_FILE_CHANGES) & (~CTRL_INFO_SRC), + 'architecture' => { + name => 'Architecture', + allowed => (ALL_PKG | ALL_SRC | CTRL_FILE_BUILDINFO | CTRL_FILE_CHANGES) & (~CTRL_INFO_SRC), separator => FIELD_SEP_SPACE, }, - 'Binary' => { - allowed => CTRL_PKG_SRC | CTRL_FILE_CHANGES, + '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' => { + 'binary-only' => { + name => 'Binary-Only', allowed => ALL_CHANGES, }, - 'Breaks' => { + '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' => { + 'bugs' => { + name => 'Bugs', allowed => (ALL_PKG | CTRL_INFO_SRC | CTRL_FILE_VENDOR) & (~CTRL_INFO_PKG), }, - 'Build-Conflicts' => { + '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' => { + 'build-conflicts-arch' => { + name => 'Build-Conflicts-Arch', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 5, }, - 'Build-Conflicts-Indep' => { + 'build-conflicts-indep' => { + name => 'Build-Conflicts-Indep', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 6, }, - 'Build-Depends' => { + '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' => { + 'build-depends-arch' => { + name => 'Build-Depends-Arch', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 2, }, - 'Build-Depends-Indep' => { + 'build-depends-indep' => { + name => 'Build-Depends-Indep', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 3, }, - 'Build-Profiles' => { + '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, }, - 'Built-For-Profiles' => { + 'built-for-profiles' => { + name => 'Built-For-Profiles', allowed => ALL_PKG | CTRL_FILE_CHANGES, separator => FIELD_SEP_SPACE, }, - 'Built-Using' => { + 'built-using' => { + name => 'Built-Using', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 10, }, - 'Changed-By' => { + 'changed-by' => { + name => 'Changed-By', allowed => CTRL_FILE_CHANGES, }, - 'Changes' => { + 'changelogs' => { + name => 'Changelogs', + allowed => CTRL_REPO_RELEASE, + }, + 'changes' => { + name => 'Changes', allowed => ALL_CHANGES, }, - 'Closes' => { + '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, }, - 'Conffiles' => { + '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' => { + 'config-version' => { + name => 'Config-Version', allowed => CTRL_FILE_STATUS, }, - 'Conflicts' => { + 'conflicts' => { + name => 'Conflicts', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 6, }, - 'Date' => { - allowed => ALL_CHANGES, + 'copyright' => { + name => 'Copyright', + allowed => CTRL_COPYRIGHT_HEADER | CTRL_COPYRIGHT_FILES, }, - 'Depends' => { - allowed => ALL_PKG, + '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' => { - allowed => ALL_PKG | CTRL_FILE_CHANGES, + 'description' => { + name => 'Description', + allowed => ALL_SRC | ALL_PKG | CTRL_FILE_CHANGES | CTRL_REPO_RELEASE, }, - 'Directory' => { + 'disclaimer' => { + name => 'Disclaimer', + allowed => CTRL_COPYRIGHT_HEADER, + }, + 'directory' => { + name => 'Directory', allowed => CTRL_INDEX_SRC, }, - 'Distribution' => { + 'distribution' => { + name => 'Distribution', allowed => ALL_CHANGES, }, - 'Enhances' => { + 'enhances' => { + name => 'Enhances', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 5, }, - 'Essential' => { + 'environment' => { + name => 'Environment', + allowed => CTRL_FILE_BUILDINFO, + separator => FIELD_SEP_LINE, + }, + 'essential' => { + name => 'Essential', allowed => ALL_PKG, }, - 'Filename' => { + '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' => { - allowed => CTRL_PKG_SRC | CTRL_FILE_CHANGES, + 'files' => { + name => 'Files', + allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_CHANGES | CTRL_COPYRIGHT_FILES, separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, }, - 'Format' => { - allowed => CTRL_PKG_SRC | CTRL_FILE_CHANGES, + 'format' => { + name => 'Format', + allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_CHANGES | CTRL_COPYRIGHT_HEADER | CTRL_FILE_BUILDINFO, }, - 'Homepage' => { + 'homepage' => { + name => 'Homepage', allowed => ALL_SRC | ALL_PKG, }, - 'Installed-Size' => { + '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' => { + 'installer-menu-item' => { + name => 'Installer-Menu-Item', allowed => ALL_PKG, }, - 'Kernel-Version' => { + 'kernel-version' => { + name => 'Kernel-Version', allowed => ALL_PKG, }, - 'Origin' => { - allowed => (ALL_PKG | ALL_SRC) & (~CTRL_INFO_PKG), + 'label' => { + name => 'Label', + allowed => CTRL_REPO_RELEASE, }, - 'Maintainer' => { - allowed => CTRL_PKG_DEB | ALL_SRC | ALL_CHANGES, + 'license' => { + name => 'License', + allowed => ALL_COPYRIGHT, }, - 'Multi-Arch' => { - allowed => ALL_PKG, + '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, }, - 'Package' => { + 'multi-arch' => { + name => 'Multi-Arch', allowed => ALL_PKG, }, - 'Package-List' => { + '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' => { + 'package-type' => { + name => 'Package-Type', allowed => ALL_PKG, }, - 'Parent' => { + 'parent' => { + name => 'Parent', allowed => CTRL_FILE_VENDOR, }, - 'Pre-Depends' => { + 'pre-depends' => { + name => 'Pre-Depends', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 1, }, - 'Priority' => { + 'priority' => { + name => 'Priority', allowed => CTRL_INFO_SRC | CTRL_INDEX_SRC | ALL_PKG, }, - 'Provides' => { + 'provides' => { + name => 'Provides', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 9, }, - 'Recommends' => { + 'recommends' => { + name => 'Recommends', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 3, }, - 'Replaces' => { + 'replaces' => { + name => 'Replaces', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'union', dep_order => 8, }, - 'Section' => { + '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, }, - 'Size' => { + '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' => { - allowed => (ALL_PKG | ALL_SRC | ALL_CHANGES) & + 'source' => { + name => 'Source', + allowed => (ALL_PKG | ALL_SRC | ALL_CHANGES | CTRL_COPYRIGHT_HEADER | CTRL_FILE_BUILDINFO) & (~(CTRL_INDEX_SRC | CTRL_INFO_PKG)), }, - 'Standards-Version' => { + 'standards-version' => { + name => 'Standards-Version', allowed => ALL_SRC, }, - 'Status' => { + 'status' => { + name => 'Status', allowed => CTRL_FILE_STATUS, separator => FIELD_SEP_SPACE, }, - 'Subarchitecture' => { + 'subarchitecture' => { + name => 'Subarchitecture', allowed => ALL_PKG, }, - 'Suggests' => { + 'suite' => { + name => 'Suite', + allowed => CTRL_REPO_RELEASE, + }, + 'suggests' => { + name => 'Suggests', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, dependency => 'normal', dep_order => 4, }, - 'Tag' => { + 'tag' => { + name => 'Tag', allowed => ALL_PKG, separator => FIELD_SEP_COMMA, }, - 'Task' => { + 'task' => { + name => 'Task', allowed => ALL_PKG, }, - 'Testsuite' => { + '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, }, - 'Triggers-Awaited' => { + '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' => { + 'triggers-pending' => { + name => 'Triggers-Pending', allowed => CTRL_FILE_STATUS, separator => FIELD_SEP_SPACE, }, - 'Uploaders' => { + 'uploaders' => { + name => 'Uploaders', allowed => ALL_SRC, separator => FIELD_SEP_COMMA, }, - 'Urgency' => { + 'upstream-name' => { + name => 'Upstream-Name', + allowed => CTRL_COPYRIGHT_HEADER, + }, + 'upstream-contact' => { + name => 'Upstream-Contact', + allowed => CTRL_COPYRIGHT_HEADER, + }, + 'urgency' => { + name => 'Urgency', allowed => ALL_CHANGES, }, - 'Vcs-Browser' => { + 'valid-until' => { + name => 'Valid-Until', + allowed => CTRL_REPO_RELEASE, + }, + 'vcs-browser' => { + name => 'Vcs-Browser', allowed => ALL_SRC, }, - 'Vcs-Arch' => { + 'vcs-arch' => { + name => 'Vcs-Arch', allowed => ALL_SRC, }, - 'Vcs-Bzr' => { + 'vcs-bzr' => { + name => 'Vcs-Bzr', allowed => ALL_SRC, }, - 'Vcs-Cvs' => { + 'vcs-cvs' => { + name => 'Vcs-Cvs', allowed => ALL_SRC, }, - 'Vcs-Darcs' => { + 'vcs-darcs' => { + name => 'Vcs-Darcs', allowed => ALL_SRC, }, - 'Vcs-Git' => { + 'vcs-git' => { + name => 'Vcs-Git', allowed => ALL_SRC, }, - 'Vcs-Hg' => { + 'vcs-hg' => { + name => 'Vcs-Hg', allowed => ALL_SRC, }, - 'Vcs-Mtn' => { + 'vcs-mtn' => { + name => 'Vcs-Mtn', allowed => ALL_SRC, }, - 'Vcs-Svn' => { + 'vcs-svn' => { + name => 'Vcs-Svn', allowed => ALL_SRC, }, - 'Vendor' => { + 'vendor' => { + name => 'Vendor', allowed => CTRL_FILE_VENDOR, }, - 'Vendor-Url' => { + 'vendor-url' => { + name => 'Vendor-Url', allowed => CTRL_FILE_VENDOR, }, - 'Version' => { - allowed => (ALL_PKG | ALL_SRC | ALL_CHANGES) & + 'version' => { + name => 'Version', + allowed => (ALL_PKG | ALL_SRC | CTRL_FILE_BUILDINFO | ALL_CHANGES) & (~(CTRL_INFO_SRC | CTRL_INFO_PKG)), }, ); -my @checksum_fields = map { &field_capitalize("Checksums-$_") } checksums_get_list(); -my @sum_fields = map { $_ eq 'md5' ? 'MD5sum' : &field_capitalize($_) } - checksums_get_list(); -&field_register($_, CTRL_PKG_SRC | CTRL_FILE_CHANGES) foreach @checksum_fields; -&field_register($_, CTRL_INDEX_PKG, - separator => FIELD_SEP_LINE | FIELD_SEP_SPACE) foreach @sum_fields; +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 Architecture Subarchitecture - Installer-Menu-Item Essential Origin Bugs - Maintainer Installed-Size), &field_list_pkg_dep(), - qw(Section Priority Multi-Arch Homepage Description Tag Task) + qw(package package-type source version built-using kernel-version + built-for-profiles auto-built-package architecture subarchitecture + installer-menu-item build-essential essential 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 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 Standards-Version Vcs-Browser - Vcs-Arch Vcs-Bzr Vcs-Cvs Vcs-Darcs Vcs-Git Vcs-Hg Vcs-Mtn - Vcs-Svn Testsuite), &field_list_src_dep(), qw(Package-List), - @checksum_fields, qw(Files) + 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 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), - @checksum_fields, qw(Files) + 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 - Date Closes Changes) + 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 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) + CTRL_FILE_STATUS() => [ + # Same as fieldinfos in lib/dpkg/parse.c + qw(package essential 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) ], ); -# Order for CTRL_INDEX_PKG is derived from CTRL_PKG_DEB -$FIELD_ORDER{CTRL_INDEX_PKG()} = [ @{$FIELD_ORDER{CTRL_PKG_DEB()}} ]; -&field_insert_before(CTRL_INDEX_PKG, 'Section', 'Filename', 'Size', @sum_fields); -# Order for CTRL_INDEX_SRC is derived from CTRL_PKG_SRC -$FIELD_ORDER{CTRL_INDEX_SRC()} = [ @{$FIELD_ORDER{CTRL_PKG_SRC()}} ]; -@{$FIELD_ORDER{CTRL_INDEX_SRC()}} = map { $_ eq 'Source' ? 'Package' : $_ } - @{$FIELD_ORDER{CTRL_PKG_SRC()}}; -&field_insert_after(CTRL_INDEX_SRC, 'Version', 'Priority', 'Section'); -&field_insert_before(CTRL_INDEX_SRC, 'Checksums-Md5', 'Directory'); =encoding utf8 @@ -416,7 +689,7 @@ CTRL_* constants exported by Dpkg::Control. =over 4 -=item my $f = field_capitalize($field_name) +=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). @@ -425,9 +698,10 @@ except the first of each word (words are separated by a hyphen in field names). sub field_capitalize($) { my $field = lc(shift); - # Some special cases due to history - return 'MD5sum' if $field eq 'md5sum'; - return uc($field) if checksums_is_supported($field); + + # Use known fields first. + return $FIELDS{$field}{name} if exists $FIELDS{$field}; + # Generic case return join '-', map { ucfirst } split /-/, $field; } @@ -439,7 +713,7 @@ Returns true if the field is official and known. =cut sub field_is_official($) { - my $field = field_capitalize(shift); + my $field = lc shift; return exists $FIELDS{$field}; } @@ -459,8 +733,9 @@ Undef is returned for non-official fields. sub field_is_allowed_in($@) { my ($field, @types) = @_; - $field = field_capitalize($field); - return unless field_is_official($field); + $field = lc $field; + + return unless exists $FIELDS{$field}; return 0 if not scalar(@types); foreach my $type (@types) { @@ -478,7 +753,7 @@ $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 alway copied as is (the X- prefix is kept). Otherwise they are not +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" @@ -552,7 +827,10 @@ The list might be empty for types where the order does not matter much. sub field_ordered_list($) { my $type = shift; - return @{$FIELD_ORDER{$type}} if exists $FIELD_ORDER{$type}; + + if (exists $FIELD_ORDER{$type}) { + return map { $FIELDS{$_}{name} } @{$FIELD_ORDER{$type}}; + } return (); } @@ -564,7 +842,9 @@ Debian package. =cut sub field_list_src_dep() { - my @list = sort { + my @list = map { + $FIELDS{$_}{name} + } sort { $FIELDS{$a}{dep_order} <=> $FIELDS{$b}{dep_order} } grep { field_is_allowed_in($_, CTRL_PKG_SRC) and @@ -582,13 +862,14 @@ the stronger to the weaker. =cut sub field_list_pkg_dep() { - my @keys = keys %FIELDS; - my @list = sort { + 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; + } keys %FIELDS; return @list; } @@ -602,9 +883,9 @@ Breaks, ...). Returns undef for fields which are not dependencies. =cut sub field_get_dep_type($) { - my $field = field_capitalize(shift); + my $field = lc shift; - return unless field_is_official($field); + return unless exists $FIELDS{$field}; return $FIELDS{$field}{dependency} if exists $FIELDS{$field}{dependency}; return; } @@ -617,7 +898,7 @@ FIELD_SEP_SPACE, FIELD_SEP_COMMA or FIELD_SEP_LINE. =cut sub field_get_sep_type($) { - my $field = field_capitalize(shift); + my $field = lc shift; return $FIELDS{$field}{separator} if exists $FIELDS{$field}{separator}; return FIELD_SEP_UNKNOWN; @@ -632,8 +913,9 @@ types. %opts is optional sub field_register($$;@) { my ($field, $types, %opts) = @_; - $field = field_capitalize($field); + $field = lc $field; $FIELDS{$field} = { + name => field_capitalize($field), allowed => $types, %opts }; @@ -648,7 +930,7 @@ type $type. sub field_insert_after($$@) { my ($type, $field, @fields) = @_; return 0 if not exists $FIELD_ORDER{$type}; - ($field, @fields) = map { field_capitalize($_) } ($field, @fields); + ($field, @fields) = map { lc } ($field, @fields); @{$FIELD_ORDER{$type}} = map { ($_ eq $field) ? ($_, @fields) : $_ } @{$FIELD_ORDER{$type}}; @@ -664,7 +946,7 @@ type $type. sub field_insert_before($$@) { my ($type, $field, @fields) = @_; return 0 if not exists $FIELD_ORDER{$type}; - ($field, @fields) = map { field_capitalize($_) } ($field, @fields); + ($field, @fields) = map { lc } ($field, @fields); @{$FIELD_ORDER{$type}} = map { ($_ eq $field) ? (@fields, $_) : $_ } @{$FIELD_ORDER{$type}}; @@ -679,10 +961,6 @@ sub field_insert_before($$@) { Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Control/Hash.pm b/scripts/Dpkg/Control/Hash.pm index 5ab76d802..607ad2f54 100644 --- a/scripts/Dpkg/Control/Hash.pm +++ b/scripts/Dpkg/Control/Hash.pm @@ -43,10 +43,6 @@ field knowledge. Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Control/HashCore.pm b/scripts/Dpkg/Control/HashCore.pm index 1ff87ea5e..e83522729 100644 --- a/scripts/Dpkg/Control/HashCore.pm +++ b/scripts/Dpkg/Control/HashCore.pm @@ -65,7 +65,7 @@ spaces are stripped only on the first line of each field. =over 4 -=item my $c = Dpkg::Control::Hash->new(%opts) +=item $c = Dpkg::Control::Hash->new(%opts) Creates a new object with the indicated options. Supported options are: @@ -109,7 +109,7 @@ sub new { my $class = ref($this) || $this; # Object is a scalar reference and not a hash ref to avoid - # infinite recursion due to overloading hash-derefencing + # infinite recursion due to overloading hash-dereferencing my $self = \{ in_order => [], out_order => [], @@ -149,7 +149,7 @@ sub set_options { $$self->{$_} = $opts{$_} foreach keys %opts; } -=item my $value = $c->get_option($option) +=item $value = $c->get_option($option) Returns the value of the corresponding option. @@ -183,7 +183,9 @@ sub parse_error { 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. Returns true if some fields have been parsed. +messages. When called multiple times, the parsed fields are accumulated. + +Returns true if some fields have been parsed. =cut @@ -197,14 +199,23 @@ sub parse { 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; - next if m/^\s*$/ and $paraborder; - next if (m/^#/); + my $armor = $_; + s/\s+$//; + + next if length == 0 and $paraborder; + + my $lead = substr $_, 0, 1; + next if $lead eq '#'; $paraborder = 0; - if (m/^(\S+?)\s*:\s*(.*)$/) { + + my ($name, $value) = split /\s*:\s*/, $_, 2; + if (defined $name and $name =~ m/^\S+?$/) { $parabody = 1; - my ($name, $value) = ($1, $2); - if ($name =~ m/^-/) { + if ($lead eq '-') { $self->parse_error($desc, g_('field cannot start with a hyphen')); } if (exists $self->{$name}) { @@ -212,7 +223,6 @@ sub parse { $self->parse_error($desc, g_('duplicate field %s found'), $name); } } - $value =~ s/\s*$//; $self->{$name} = $value; $cf = $name; } elsif (m/^\s(\s*\S.*)$/) { @@ -223,20 +233,9 @@ sub parse { if ($line =~ /^\.+$/) { $line = substr $line, 1; } - $line =~ s/\s*$//; $self->{$cf} .= "\n$line"; - } elsif (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')); - } - } elsif (m/^\s*$/ || - ($expect_pgp_sig && m/^-----BEGIN PGP SIGNATURE-----[\r\t ]*$/)) { + } 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*$/; @@ -262,6 +261,16 @@ sub parse { $$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)')); @@ -309,7 +318,7 @@ sub get_custom_field { Write the string representation of the control information to a file. -=item my $str = $c->output() +=item $str = $c->output() =item "$c" @@ -400,9 +409,7 @@ sub apply_substvars { my ($self, $substvars, %opts) = @_; # Add substvars to refer to other fields - foreach my $f (keys %$self) { - $substvars->set_as_auto("F:$f", $self->{$f}); - } + $substvars->set_field_substvars($self, 'F'); foreach my $f (keys %$self) { my $v = $substvars->substvars($self->{$f}, %opts); @@ -444,7 +451,6 @@ package Dpkg::Control::HashCore::Tie; use strict; use warnings; -use Dpkg::Checksums; use Dpkg::Control::FieldsCore; use Carp; @@ -454,7 +460,7 @@ 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 that reference gets DESTROYed +# Dpkg::Control::Hash, hence ensuring that reference gets DESTROYed # properly. # Dpkg::Control::Hash->new($parent) @@ -465,7 +471,7 @@ use parent -norequire, qw(Tie::ExtraHash); sub new { my $class = shift; my $hash = {}; - tie %{$hash}, $class, @_; + tie %{$hash}, $class, @_; ## no critic (Miscellanea::ProhibitTies) return $hash; } @@ -486,10 +492,9 @@ sub FETCH { sub STORE { my ($self, $key, $value) = @_; - my $parent = $self->[1]; $key = lc($key); if (not exists $self->[0]->{$key}) { - push @{$parent->{in_order}}, field_capitalize($key); + push @{$self->[1]->{in_order}}, field_capitalize($key); } $self->[0]->{$key} = $value; } @@ -550,10 +555,6 @@ New method: $c->parse_error(). Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Control/Info.pm b/scripts/Dpkg/Control/Info.pm index 5bf1639e4..a5eae8732 100644 --- a/scripts/Dpkg/Control/Info.pm +++ b/scripts/Dpkg/Control/Info.pm @@ -99,8 +99,8 @@ loads from the standard input. 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. +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 @@ -221,10 +221,6 @@ New argument: The $c->new() constructor accepts an %opts argument. Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Control/Tests.pm b/scripts/Dpkg/Control/Tests.pm new file mode 100644 index 000000000..439eee8c8 --- /dev/null +++ b/scripts/Dpkg/Control/Tests.pm @@ -0,0 +1,83 @@ +# 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 an object 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; diff --git a/scripts/Dpkg/Control/Tests/Entry.pm b/scripts/Dpkg/Control/Tests/Entry.pm new file mode 100644 index 000000000..92eea49f4 --- /dev/null +++ b/scripts/Dpkg/Control/Tests/Entry.pm @@ -0,0 +1,94 @@ +# 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 object 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; diff --git a/scripts/Dpkg/Control/Types.pm b/scripts/Dpkg/Control/Types.pm index 09e12d155..5d9496a90 100644 --- a/scripts/Dpkg/Control/Types.pm +++ b/scripts/Dpkg/Control/Types.pm @@ -21,14 +21,20 @@ 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); @@ -51,16 +57,38 @@ between Dpkg::Control and Dpkg::Control::Fields. use constant { CTRL_UNKNOWN => 0, - CTRL_INFO_SRC => 1, # First control block in debian/control - CTRL_INFO_PKG => 2, # Subsequent control blocks in debian/control - CTRL_INDEX_SRC => 4, # Entry in repository's Packages files - CTRL_INDEX_PKG => 8, # Entry in repository's Sources files - CTRL_PKG_SRC => 16, # .dsc file of source package - CTRL_PKG_DEB => 32, # DEBIAN/control in binary packages - CTRL_FILE_CHANGES => 64, # .changes file - CTRL_FILE_VENDOR => 128, # File in $Dpkg::CONFDIR/origins - CTRL_FILE_STATUS => 256, # $Dpkg::ADMINDIR/status - CTRL_CHANGELOG => 512, # Output of dpkg-parsechangelog + # 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 @@ -69,10 +97,6 @@ use constant { This is a private module. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Deps.pm b/scripts/Dpkg/Deps.pm index 182334028..3560e1a72 100644 --- a/scripts/Dpkg/Deps.pm +++ b/scripts/Dpkg/Deps.pm @@ -49,7 +49,7 @@ All the deps_* functions are exported by default. use strict; use warnings; -our $VERSION = '1.05'; +our $VERSION = '1.06'; our @EXPORT = qw( deps_concat deps_parse @@ -58,10 +58,11 @@ our @EXPORT = qw( deps_compare ); +use Carp; use Exporter qw(import); use Dpkg::Version; -use Dpkg::Arch qw(get_host_arch get_build_arch); +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; @@ -159,7 +160,7 @@ sub deps_eval_implication { return; } -=item my $dep = deps_concat(@dep_list) +=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. @@ -172,7 +173,7 @@ sub deps_concat { return join ', ', grep { defined } @dep_list; } -=item my $dep = deps_parse($line, %options) +=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 @@ -198,7 +199,7 @@ 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 implicitely strips off the architecture restriction +architecture. This implicitly strips off the architecture restriction list so that the resulting dependencies are directly applicable to the current architecture. @@ -237,6 +238,12 @@ this when parsing non-dependency fields like Conflicts. 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 @@ -244,21 +251,40 @@ This should be set whenever working with build-deps. 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{host_arch} //= get_host_arch(); - $options{build_arch} //= get_build_arch(); $options{use_profiles} //= 1; $options{reduce_profiles} //= 0; - $options{build_profiles} //= [ get_build_profiles() ]; $options{reduce_restrictions} //= 0; $options{union} //= 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+//; @@ -268,12 +294,7 @@ sub deps_parse { 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, host_arch => - $options{host_arch}, - build_arch => - $options{build_arch}, - build_dep => - $options{build_dep}); + 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; @@ -315,7 +336,7 @@ sub deps_parse { return $dep_and; } -=item my $bool = deps_iterate($deps, $callback_func) +=item $bool = deps_iterate($deps, $callback_func) This function visits all elements of the dependency object, calling the callback function for each element. @@ -336,15 +357,15 @@ sub deps_iterate { return unless defined $dep; if ($dep->isa('Dpkg::Deps::Simple')) { - return unless &{$callback_func}($dep); + return unless $callback_func->($dep); } else { - return unless &{$visitor_func}($dep->get_deps()); + return unless $visitor_func->($dep->get_deps()); } } return 1; }; - return &{$visitor_func}($deps); + return $visitor_func->($deps); } =item deps_compare($a, $b) @@ -366,26 +387,31 @@ my %relation_ordering = ( ); sub deps_compare { - my ($a, $b) = @_; - return -1 if $a->is_empty(); - return 1 if $b->is_empty(); - while ($a->isa('Dpkg::Deps::Multiple')) { - return -1 if $a->is_empty(); - my @deps = $a->get_deps(); - $a = $deps[0]; - } - while ($b->isa('Dpkg::Deps::Multiple')) { - return 1 if $b->is_empty(); - my @deps = $b->get_deps(); - $b = $deps[0]; + 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; } - my $ar = $a->{relation} // 'undef'; - my $br = $b->{relation} // 'undef'; - my $av = $a->{version} // ''; - my $bv = $a->{version} // ''; - return (($a->{package} cmp $b->{package}) || - ($relation_ordering{$ar} <=> $relation_ordering{$br}) || - ($av cmp $bv)); } @@ -546,12 +572,11 @@ use warnings; use Carp; -use Dpkg::Arch qw(debarch_is_concerned); +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 Dpkg::Util qw(:list); use parent qw(Dpkg::Interface::Storable); @@ -561,9 +586,10 @@ sub new { my $self = {}; bless $self, $class; $self->reset(); - $self->{host_arch} = $opts{host_arch} || Dpkg::Arch::get_host_arch(); - $self->{build_arch} = $opts{build_arch} || Dpkg::Arch::get_build_arch(); + $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; } @@ -587,9 +613,17 @@ sub parse { 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 - ([a-zA-Z0-9][a-zA-Z0-9+.-]*) # package name + ($pkgname_re) # package name (?: # start of optional part : # colon for architecture ([a-zA-Z0-9][a-zA-Z0-9-]*) # architecture name @@ -597,18 +631,20 @@ sub parse_string { (?: # start of optional part \s* \( # open parenthesis for version part \s* (<<|<=|=|>=|>>|[<>]) # relation part - \s* (.*?) # do not attempt to parse version + \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* ([^\]]+) # don't parse architectures now \s* \] # closing bracket )? # end of optional architecture - (?: # start of optional restriction + ( + (?: # start of optional restriction \s* < # open bracket for restriction - \s* (.*) # do not parse restrictions now + \s* [^>]+ # do not parse restrictions now \s* > # closing bracket + )+ )? # end of optional restriction \s*$ # trailing spaces at end }x; @@ -622,7 +658,7 @@ sub parse_string { $self->{version} = Dpkg::Version->new($4); } if (defined($5)) { - $self->{arches} = [ split(/\s+/, $5) ]; + $self->{arches} = [ debarch_list_parse($5) ]; } if (defined($6)) { $self->{restrictions} = [ parse_build_profiles($6) ]; @@ -716,25 +752,50 @@ sub _arch_is_superset { return 1; } -# _arch_qualifier_allows_implication($p, $q) +# _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. -sub _arch_qualifier_allows_implication { +# implication $p -> $q, false otherwise. $p/$q can be undef/"any"/"native" +# or an architecture string. +# +# Because we are handling dependencies in isolation, and the full context +# of the implications are only known when doing dependency resolution at +# run-time, we can only assert that they are implied if they are equal. +sub _arch_qualifier_implies { my ($p, $q) = @_; - if (defined $p and $p eq 'any') { - return 1 if defined $q and $q eq 'any'; - return 0; - } elsif (defined $p and $p eq 'native') { - return 1 if defined $q and ($q eq 'any' or $q eq 'native'); - return 0; - } elsif (defined $p) { - return 1 if defined $q and ($p eq $q or $q eq 'any'); - return 0; + + 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 { - return 0 if defined $q and $q ne 'any' and $q ne 'native'; - return 1; + # 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; } } @@ -752,8 +813,12 @@ sub implies { return unless _arch_is_superset($self->{arches}, $o->{arches}); # The arch qualifier must not forbid an implication - return unless _arch_qualifier_allows_implication($self->{archqual}, - $o->{archqual}); + 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}; @@ -1247,7 +1312,7 @@ Those methods are not meaningful for this object and always return undef. =item $union->simplify_deps($facts) -The simplication is done to generate an union of all the relationships. +The simplification is done to generate an union of all the relationships. It uses $simple_dep->merge_union($other_dep) to get its job done. =back @@ -1302,7 +1367,7 @@ packages provided (by the set of installed packages). =over 4 -=item my $facts = Dpkg::Deps::KnownFacts->new(); +=item $facts = Dpkg::Deps::KnownFacts->new(); Creates a new object. @@ -1311,8 +1376,6 @@ Creates a new object. use strict; use warnings; -use Carp; - use Dpkg::Version; sub new { @@ -1365,7 +1428,7 @@ sub add_provided_package { push @{$self->{virtualpkg}{$pkg}}, [ $by, $rel, $ver ]; } -=item my ($check, $param) = $facts->check_package($package) +=item ($check, $param) = $facts->check_package($package) $check is one when the package is found. For a real package, $param contains the version. For a virtual package, $param contains an array @@ -1383,8 +1446,8 @@ methods where appropriate, but it should not be directly queried. sub check_package { my ($self, $pkg) = @_; - carp 'obsolete function, pass Dpkg::Deps::KnownFacts to Dpkg::Deps ' . - 'methods instead'; + warnings::warnif('deprecated', 'obsolete function, pass ' . + 'Dpkg::Deps::KnownFacts to Dpkg::Deps methods instead'); if (exists $self->{pkg}{$pkg}) { return (1, $self->{pkg}{$pkg}[0]{version}); @@ -1401,8 +1464,8 @@ 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}; - my $build_arch = $dep->{build_arch}; + 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}; @@ -1464,6 +1527,10 @@ sub _evaluate_simple_dep { =head1 CHANGES +=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(). diff --git a/scripts/Dpkg/Dist/Files.pm b/scripts/Dpkg/Dist/Files.pm index 8fba17f35..c2c426bd9 100644 --- a/scripts/Dpkg/Dist/Files.pm +++ b/scripts/Dpkg/Dist/Files.pm @@ -20,6 +20,8 @@ use warnings; our $VERSION = '0.01'; +use IO::Dir; + use Dpkg::Gettext; use Dpkg::ErrorHandling; @@ -52,13 +54,13 @@ sub parse_filename { my $file; - if ($fn =~ m/^(([-+.0-9a-z]+)_([^_]+)_([-\w]+)\.([a-z0-9.]+))$/) { + if ($fn =~ m/^(([-+:.0-9a-z]+)_([^_]+)_([-\w]+)\.([a-z0-9.]+))$/) { $file->{filename} = $1; $file->{package} = $2; $file->{version} = $3; $file->{arch} = $4; $file->{package_type} = $5; - } elsif ($fn =~ m/^([-+.,_0-9a-zA-Z~]+)$/) { + } elsif ($fn =~ m/^([-+:.,_0-9a-zA-Z~]+)$/) { $file->{filename} = $1; } else { $file = undef; @@ -101,6 +103,21 @@ sub parse { 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; @@ -122,6 +139,8 @@ sub add_file { $file->{priority} = $priority; $self->{files}->{$filename} = $file; + + return $file; } sub del_file { @@ -138,7 +157,7 @@ sub filter { foreach my $filename (keys %{$self->{files}}) { my $file = $self->{files}->{$filename}; - if (not &$keep($file) or &$remove($file)) { + if (not $keep->($file) or $remove->($file)) { delete $self->{files}->{$filename}; } } diff --git a/scripts/Dpkg/ErrorHandling.pm b/scripts/Dpkg/ErrorHandling.pm index ce01d5ea6..81bc00d53 100644 --- a/scripts/Dpkg/ErrorHandling.pm +++ b/scripts/Dpkg/ErrorHandling.pm @@ -15,18 +15,32 @@ 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 ); @@ -37,8 +51,74 @@ 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) = @_; @@ -46,43 +126,107 @@ sub report_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 (@_); - return "$Dpkg::PROGNAME: $type: $msg\n"; + + 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(g_('info'), @_) if (!$quiet_warnings); + print { $info_fh } report(REPORT_INFO, @_) if not $quiet_warnings; +} + +sub notice +{ + warn report(REPORT_NOTICE, @_) if not $quiet_warnings; } sub warning($;@) { - warn report(g_('warning'), @_) if (!$quiet_warnings); + warn report(REPORT_WARN, @_) if not $quiet_warnings; } sub syserr($;@) { my $msg = shift; - die report(g_('error'), "$msg: $!", @_); + die report(REPORT_ERROR, "$msg: $!", @_); } sub error($;@) { - die report(g_('error'), @_); + die report(REPORT_ERROR, @_); } sub errormsg($;@) { - print { *STDERR } report(g_('error'), @_); + print { *STDERR } report(REPORT_ERROR, @_); +} + +sub printcmd +{ + my (@cmd) = @_; + + print { *STDERR } report_pretty(" @cmd\n", report_color(REPORT_COMMAND)); } sub subprocerr(@) @@ -94,23 +238,25 @@ sub subprocerr(@) require POSIX; if (POSIX::WIFEXITED($?)) { - error(g_('%s gave error exit status %s'), $p, POSIX::WEXITSTATUS($?)); + my $ret = POSIX::WEXITSTATUS($?); + error(g_('%s subprocess returned exit status %d'), $p, $ret); } elsif (POSIX::WIFSIGNALED($?)) { - error(g_('%s died from signal %s'), $p, POSIX::WTERMSIG($?)); + my $sig = POSIX::WTERMSIG($?); + error(g_('%s subprocess was killed by signal %d'), $p, $sig); } else { - error(g_('%s failed with unknown exit code %d'), $p, $?); + error(g_('%s subprocess failed with unknown status code %d'), $p, $?); } } -my $printforhelp = g_('Use --help for program usage information.'); - sub usageerr(@) { my ($msg) = (shift); + state $printforhelp = g_('Use --help for program usage information.'); + $msg = sprintf($msg, @_) if (@_); - warn "$Dpkg::PROGNAME: $msg\n\n"; - warn "$printforhelp\n"; + warn report(REPORT_ERROR, $msg); + warn "\n$printforhelp\n"; exit(2); } diff --git a/scripts/Dpkg/Exit.pm b/scripts/Dpkg/Exit.pm index 1861de7f0..5e513b496 100644 --- a/scripts/Dpkg/Exit.pm +++ b/scripts/Dpkg/Exit.pm @@ -75,17 +75,17 @@ Run the registered exit handlers. =cut sub run_exit_handlers { - &$_() foreach (reverse @handlers); + $_->() foreach (reverse @handlers); } -sub exit_handler { +sub _exit_handler { run_exit_handlers(); exit(127); } -$SIG{INT} = \&exit_handler; -$SIG{HUP} = \&exit_handler; -$SIG{QUIT} = \&exit_handler; +$SIG{INT} = \&_exit_handler; +$SIG{HUP} = \&_exit_handler; +$SIG{QUIT} = \&_exit_handler; =back diff --git a/scripts/Dpkg/File.pm b/scripts/Dpkg/File.pm index c6ae3264c..884923852 100644 --- a/scripts/Dpkg/File.pm +++ b/scripts/Dpkg/File.pm @@ -21,36 +21,10 @@ use warnings; our $VERSION = '0.01'; our @EXPORT = qw( - file_lock file_slurp ); 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 'use File::FcntlLock'; - if ($@) { - 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); - } - } -} sub file_slurp { my $fh = shift; diff --git a/scripts/Dpkg/Getopt.pm b/scripts/Dpkg/Getopt.pm index 4d677f391..bebe9f8d3 100644 --- a/scripts/Dpkg/Getopt.pm +++ b/scripts/Dpkg/Getopt.pm @@ -18,7 +18,7 @@ package Dpkg::Getopt; use strict; use warnings; -our $VERSION = '0.01'; +our $VERSION = '0.02'; our @EXPORT = qw( normalize_options ); @@ -27,17 +27,20 @@ use Exporter qw(import); sub normalize_options { - my (@args) = @_; + my (%opts) = @_; + my $norm = 1; + my @args; @args = map { - if (m/^(-[A-Za-z])(.+)$/) { + if ($norm and m/^(-[A-Za-z])(.+)$/) { ($1, $2) - } elsif (m/^(--[A-Za-z-]+)=(.*)$/) { + } elsif ($norm and m/^(--[A-Za-z-]+)=(.*)$/) { ($1, $2) } else { + $norm = 0 if defined $opts{delim} and $_ eq $opts{delim}; $_; } - } @args; + } @{$opts{args}}; return @args; } diff --git a/scripts/Dpkg/Gettext.pm b/scripts/Dpkg/Gettext.pm index 1ec501bf0..2e3e5042e 100644 --- a/scripts/Dpkg/Gettext.pm +++ b/scripts/Dpkg/Gettext.pm @@ -1,5 +1,8 @@ # 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: @@ -26,12 +29,13 @@ package Dpkg::Gettext; use strict; use warnings; -our $VERSION = '1.01'; +our $VERSION = '1.03'; our @EXPORT = qw( textdomain ngettext g_ P_ + N_ _g ); @@ -49,6 +53,17 @@ 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 @@ -73,31 +88,36 @@ our $DEFAULT_TEXT_DOMAIN = 'dpkg-dev'; =over 4 -=item my $trans = g_($msgid) +=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 my $trans = C_($msgctxt, $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 my $trans = P_($msgid, $msgid_plural, $n) +=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. -=back - =cut use constant GETTEXT_CONTEXT_GLUE => "\004"; BEGIN { - eval 'use Locale::gettext'; - if ($@) { + 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) { eval q{ sub g_ { return shift; @@ -137,19 +157,43 @@ BEGIN { } } +=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; +} + # XXX: Backwards compatibility, to be removed on VERSION 2.00. sub _g ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines) { my $msgid = shift; - require Carp; - Carp::carp('obsolete _g() function, please use g_() instead'); + warnings::warnif('deprecated', + 'obsolete _g() function, please use g_() instead'); return g_($msgid); } =head1 CHANGES +=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 diff --git a/scripts/Dpkg/IPC.pm b/scripts/Dpkg/IPC.pm index 261c5a682..f93dabe81 100644 --- a/scripts/Dpkg/IPC.pm +++ b/scripts/Dpkg/IPC.pm @@ -45,11 +45,11 @@ other programs in an easy, yet flexible way, while hiding all the gory details of IPC (Inter-Process Communication) from you. -=head1 METHODS +=head1 FUNCTIONS =over 4 -=item my $pid = spawn(%opts) +=item $pid = spawn(%opts) Creates a child process and executes another program in it. The arguments are interpreted as a hash of options, specifying @@ -282,7 +282,8 @@ sub spawn { } elsif ($opts{from_handle}) { open(STDIN, '<&', $opts{from_handle}) or syserr(g_('reopen stdin')); - close($opts{from_handle}); # has been duped, can be closed + # has been duped, can be closed + push @{$opts{close_in_child}}, $opts{from_handle}; } # Redirect STDOUT if needed if ($opts{to_file}) { @@ -291,7 +292,8 @@ sub spawn { } elsif ($opts{to_handle}) { open(STDOUT, '>&', $opts{to_handle}) or syserr(g_('reopen stdout')); - close($opts{to_handle}); # has been duped, can be closed + # has been duped, can be closed + push @{$opts{close_in_child}}, $opts{to_handle}; } # Redirect STDERR if needed if ($opts{error_to_file}) { @@ -300,7 +302,8 @@ sub spawn { } elsif ($opts{error_to_handle}) { open(STDERR, '>&', $opts{error_to_handle}) or syserr(g_('reopen stdout')); - close($opts{error_to_handle}); # has been duped, can be closed + # 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}}); @@ -359,7 +362,7 @@ Defaults to "child process". =item nocheck If true do not check the return status of the child (and thus -do not fail it it has been killed or if it exited with a +do not fail it has been killed or if it exited with a non-zero return code). =item timeout @@ -413,11 +416,6 @@ New options: spawn() now accepts 'sig' and 'delete_sig'. Mark the module as public. -=head1 AUTHORS - -Written by Raphaël Hertzog <hertzog@debian.org> and -Frank Lichtenheld <djpig@debian.org>. - =head1 SEE ALSO Dpkg, Dpkg::ErrorHandling diff --git a/scripts/Dpkg/Index.pm b/scripts/Dpkg/Index.pm index 7a899d437..bcee6205b 100644 --- a/scripts/Dpkg/Index.pm +++ b/scripts/Dpkg/Index.pm @@ -1,4 +1,5 @@ # 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 @@ -18,7 +19,7 @@ package Dpkg::Index; use strict; use warnings; -our $VERSION = '1.00'; +our $VERSION = '1.01'; use Dpkg::Gettext; use Dpkg::ErrorHandling; @@ -44,7 +45,7 @@ This object represent a set of Dpkg::Control objects. =over 4 -=item my $index = Dpkg::Index->new(%opts) +=item $index = Dpkg::Index->new(%opts) Creates a new empty index. See set_options() for more details. @@ -57,6 +58,7 @@ sub new { my $self = { items => {}, order => [], + unique_tuple_key => 0, get_key_func => sub { return $_[0]->{Package} }, type => CTRL_UNKNOWN, }; @@ -73,16 +75,62 @@ sub new { 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. The index can only -contain one item with a given key. The function used depend on the -type: for CTRL_INFO_PKG, CTRL_INDEX_SRC, CTRL_INDEX_PKG and CTRL_PKG_DEB -it's simply the Package field; for CTRL_PKG_SRC and CTRL_INFO_SRC, it's -the Source field; for CTRL_CHANGELOG it's the Source and the Version -fields (concatenated with an intermediary "_"); for CTRL_FILE_CHANGES it's -the Source, Version and Architecture fields (concatenated with "_"); -for CTRL_FILE_VENDOR it's the Vendor field; for CTRL_FILE_STATUS it's the -Package and Architecture fields (concatenated with "_"). Otherwise it's -the Package field by default. +returning a key for the item passed in parameters, "unique_tuple_key" is +a boolean requesting whether the default key should be the unique tuple +(default to false for backwards compatibility, but it will change to true +in dpkg 1.20.x). The index can only contain one item with a given key. +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 field by default, +or the Package and Version fields (concatenated with "_") when +"unique_tuple_key" is true; + +=item * + +for CTRL_INFO_PKG it is simply the Package field; + +=item * + +for CTRL_INDEX_PKG and CTRL_PKG_DEB it is the Package field by default, +or the Package, Version and Architecture fields (concatenated with "_") +when "unique_tuple_key" is true; + +=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 @@ -92,15 +140,55 @@ sub set_options { # Default values based on type if (exists $opts{type}) { my $t = $opts{type}; - if ($t == CTRL_INFO_PKG or $t == CTRL_INDEX_SRC or - $t == CTRL_INDEX_PKG or $t == CTRL_PKG_DEB) { + if ($t == CTRL_INFO_PKG) { $self->{get_key_func} = sub { return $_[0]->{Package}; }; - } elsif ($t == CTRL_PKG_SRC or $t == CTRL_INFO_SRC) { + } 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}; + }; + } elsif (not defined $opts{get_key_func}) { + $self->{get_key_func} = sub { + return $_[0]->{Package}; + }; + warnings::warnif('deprecated', + 'the default get_key_func for this control type will ' . + 'change semantics in dpkg 1.20.x , please set ' . + 'unique_tuple_key or get_key_func explicitly'); + } + } elsif ($t == CTRL_INDEX_PKG or $t == CTRL_PKG_DEB) { + if ($opts{unique_tuple_key} // $self->{unique_tuple_key}) { + $self->{get_key_func} = sub { + return $_[0]->{Package} . '_' . $_[0]->{Version} . '_' . + $_[0]->{Architecture}; + }; + } elsif (not defined $opts{get_key_func}) { + $self->{get_key_func} = sub { + return $_[0]->{Package}; + }; + warnings::warnif('deprecated', + 'the default get_key_func for this control type will ' . + 'change semantics in dpkg 1.20.x , please set ' . + 'unique_tuple_key or get_key_func explicitly'); + } } elsif ($t == CTRL_FILE_CHANGES) { $self->{get_key_func} = sub { return $_[0]->{Source} . '_' . $_[0]->{Version} . '_' . @@ -156,8 +244,10 @@ parsed. Handles compressed files transparently based on their extensions. =item $index->parse($fh, $desc) -Reads the filehandle and creates all items parsed. Returns the number of -items parsed. +Reads the filehandle and creates all items parsed. When called multiple +times, the parsed stanzas are accumulated. + +Returns the number of items parsed. =cut @@ -178,7 +268,7 @@ sub parse { Writes the content of the index in a file. Auto-compresses files based on their extensions. -=item my $item = $index->new_item() +=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 @@ -191,7 +281,7 @@ sub new_item { return Dpkg::Control->new(type => $self->{type}); } -=item my $item = $index->get_by_key($key) +=item $item = $index->get_by_key($key) Returns the item identified by $key or undef. @@ -203,7 +293,7 @@ sub get_by_key { return; } -=item my @keys = $index->get_keys(%criteria) +=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 @@ -219,22 +309,24 @@ sub get_keys { foreach my $s_crit (keys %crit) { # search criteria if (ref($crit{$s_crit}) eq 'Regexp') { @selected = grep { - $self->{items}{$_}{$s_crit} =~ $crit{$s_crit} + 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}); + $crit{$s_crit}->($self->{items}{$_}{$s_crit}); } @selected; } else { @selected = grep { - $self->{items}{$_}{$s_crit} eq $crit{$s_crit} + exists $self->{items}{$_}{$s_crit} and + $self->{items}{$_}{$s_crit} eq $crit{$s_crit} } @selected; } } return @selected; } -=item my @items = $index->get(%criteria) +=item @items = $index->get(%criteria) Returns all the items that matches all the criteria. @@ -257,7 +349,7 @@ sub remove_by_key { return delete $self->{items}{$key}; } -=item my @items = $index->remove(%criteria) +=item @items = $index->remove(%criteria) Returns and removes all the items that matches all the criteria. @@ -305,20 +397,20 @@ sub sort { my ($self, $func) = @_; if (defined $func) { @{$self->{order}} = sort { - &$func($self->{items}{$a}, $self->{items}{$b}) + $func->($self->{items}{$a}, $self->{items}{$b}) } @{$self->{order}}; } else { @{$self->{order}} = sort @{$self->{order}}; } } -=item my $str = $index->output() +=item $str = $index->output() =item "$index" Get a string representation of the index. The Dpkg::Control objects are output in the order which they have been read or added except if the order -hae been changed with sort(). +have been changed with sort(). =item $index->output($fh) @@ -344,13 +436,15 @@ sub output { =head1 CHANGES -=head2 Version 1.00 (dpkg 1.15.6) +=head2 Version 1.01 (dpkg 1.19.0) -Mark the module as public. +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. -=head1 AUTHOR +=head2 Version 1.00 (dpkg 1.15.6) -Raphaël Hertzog <hertzog@debian.org>. +Mark the module as public. =cut diff --git a/scripts/Dpkg/Interface/Storable.pm b/scripts/Dpkg/Interface/Storable.pm index 0e8f463fd..eb6078d3b 100644 --- a/scripts/Dpkg/Interface/Storable.pm +++ b/scripts/Dpkg/Interface/Storable.pm @@ -18,13 +18,12 @@ package Dpkg::Interface::Storable; use strict; use warnings; -our $VERSION = '1.00'; +our $VERSION = '1.01'; use Carp; use Dpkg::Gettext; use Dpkg::ErrorHandling; -use Dpkg::Compression::FileHandle; use overload '""' => \&_stringify, @@ -66,17 +65,19 @@ and it writes the same string to $fh (if it's defined). =over 4 -=item $obj->load($filename) +=item $obj->load($filename, %opts) Initialize the object with the data stored in the file. The file can be -compressed, it will be uncompressed on the fly by using a -Dpkg::Compression::FileHandle object. If $filename is "-", then the +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, @options) = @_; + my ($self, $file, %opts) = @_; + $opts{compression} //= 1; unless ($self->can('parse')) { croak ref($self) . ' cannot be loaded, it lacks the parse method'; } @@ -85,27 +86,32 @@ sub load { $fh = \*STDIN; $desc = g_('<standard input>'); } else { - $fh = Dpkg::Compression::FileHandle->new(); + 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, @options); + 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) +=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 $filename is "-", then the +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, @options) = @_; + my ($self, $file, %opts) = @_; + $opts{compression} //= 1; unless ($self->can('output')) { croak ref($self) . ' cannot be saved, it lacks the output method'; } @@ -113,10 +119,13 @@ sub save { if ($file eq '-') { $fh = \*STDOUT; } else { - $fh = Dpkg::Compression::FileHandle->new(); + 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, @options); + $self->output($fh, %opts); if ($file ne '-') { close($fh) or syserr(g_('cannot close %s'), $file); } @@ -140,13 +149,14 @@ sub _stringify { =head1 CHANGES -=head2 Version 1.00 (dpkg 1.15.6) +=head2 Version 1.01 (dpkg 1.19.0) -Mark the module as public. +New options: The $obj->load() and $obj->save() methods support a new +compression option. -=head1 AUTHOR +=head2 Version 1.00 (dpkg 1.15.6) -Raphaël Hertzog <hertzog@debian.org>. +Mark the module as public. =cut diff --git a/scripts/Dpkg/Lock.pm b/scripts/Dpkg/Lock.pm new file mode 100644 index 000000000..63447795a --- /dev/null +++ b/scripts/Dpkg/Lock.pm @@ -0,0 +1,61 @@ +# 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; diff --git a/scripts/Dpkg/OpenPGP.pm b/scripts/Dpkg/OpenPGP.pm new file mode 100644 index 000000000..858d3efcf --- /dev/null +++ b/scripts/Dpkg/OpenPGP.pm @@ -0,0 +1,80 @@ +# 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 Exporter qw(import); +use File::Copy; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Path qw(find_command); + +our $VERSION = '0.01'; +our @EXPORT = qw( + openpgp_sig_to_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; + } + + if (not find_command('gpg')) { + warning(g_('cannot OpenPGP ASCII armor signature file due to missing gpg')); + } + + open my $fh_asc, '>', $asc + or syserr(g_('cannot create signature file %s'), $asc); + open my $fh_gpg, '-|', 'gpg', '-o', '-', '--enarmor', $sig + or syserr(g_('cannot execute %s program'), 'gpg'); + while (my $line = <$fh_gpg>) { + 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 $sig; + } + + return; +} + +1; diff --git a/scripts/Dpkg/Path.pm b/scripts/Dpkg/Path.pm index ad8283ec8..f352cac35 100644 --- a/scripts/Dpkg/Path.pm +++ b/scripts/Dpkg/Path.pm @@ -36,7 +36,7 @@ use Exporter qw(import); use File::Spec; use Cwd qw(realpath); -use Dpkg::Arch qw(get_host_arch debarch_to_debtriplet); +use Dpkg::Arch qw(get_host_arch debarch_to_debtuple); use Dpkg::IPC; =encoding utf8 @@ -49,7 +49,7 @@ Dpkg::Path - some common path handling functions It provides some functions to handle various path. -=head1 METHODS +=head1 FUNCTIONS =over 8 @@ -203,7 +203,7 @@ sub resolve_symlink($) { } -=item my $cmdpath = find_command($command) +=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. @@ -224,12 +224,12 @@ sub find_command($) { return; } -=item my $control_file = get_control_path($pkg, $filetype) +=item $control_file = get_control_path($pkg, $filetype) Return the path of the control file of type $filetype for the given package. -=item my @control_files = get_control_path($pkg) +=item @control_files = get_control_path($pkg) Return the path of all available control files for the given package. @@ -250,14 +250,14 @@ sub get_control_path($;$) { return split(/\n/, $control_file); } -=item my $file = find_build_file($basename) +=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 my @files = find_build_file($basename) +=item @files = find_build_file($basename) Return the available variants of the given file. Returns an empty list if none of the files exists. @@ -267,7 +267,7 @@ list if none of the files exists. sub find_build_file($) { my $base = shift; my $host_arch = get_host_arch(); - my ($abi, $host_os, $cpu) = debarch_to_debtriplet($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; @@ -301,10 +301,6 @@ New function: find_command() Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Shlibs.pm b/scripts/Dpkg/Shlibs.pm index 59527cb62..b2fc4bc64 100644 --- a/scripts/Dpkg/Shlibs.pm +++ b/scripts/Dpkg/Shlibs.pm @@ -1,4 +1,4 @@ -# Copyright © 2007 Raphaël Hertzog <hertzog@debian.org> +# 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 @@ -20,7 +20,7 @@ use strict; use warnings; use feature qw(state); -our $VERSION = '0.02'; +our $VERSION = '0.03'; our @EXPORT_OK = qw( blank_library_paths setup_library_paths @@ -30,15 +30,14 @@ our @EXPORT_OK = qw( ); use Exporter qw(import); +use List::Util qw(none); use File::Spec; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Shlibs::Objdump; -use Dpkg::Util qw(:list); use Dpkg::Path qw(resolve_symlink canonpath); -use Dpkg::Arch qw(debarch_to_gnutriplet get_build_arch get_host_arch - gnutriplet_to_multiarch debarch_to_multiarch); +use Dpkg::Arch qw(get_build_arch get_host_arch :mappers); use constant DEFAULT_LIBRARY_PATH => qw(/lib /usr/lib); @@ -46,7 +45,10 @@ use constant DEFAULT_LIBRARY_PATH => use constant DEFAULT_MULTILIB_PATH => qw(/lib32 /usr/lib32 /lib64 /usr/lib64); -my @librarypaths; +# Library paths set by the user. +my @custom_librarypaths; +# Library paths from the system. +my @system_librarypaths; my $librarypaths_init; sub parse_crle { @@ -94,8 +96,8 @@ sub parse_ldso_conf { } elsif (m{^\s*/}) { s/^\s+//; my $libdir = $_; - if (none { $_ eq $libdir } @librarypaths) { - push @librarypaths, $libdir; + if (none { $_ eq $libdir } (@custom_librarypaths, @system_librarypaths)) { + push @system_librarypaths, $libdir; } } } @@ -103,18 +105,22 @@ sub parse_ldso_conf { } sub blank_library_paths { - @librarypaths = (); + @custom_librarypaths = (); + @system_librarypaths = (); $librarypaths_init = 1; } sub setup_library_paths { - @librarypaths = (); + @custom_librarypaths = (); + @system_librarypaths = (); # XXX: Deprecated. Update library paths with LD_LIBRARY_PATH. if ($ENV{LD_LIBRARY_PATH}) { foreach my $path (split /:/, $ENV{LD_LIBRARY_PATH}) { $path =~ s{/+$}{}; - push @librarypaths, $path; + # 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; } } @@ -134,16 +140,16 @@ sub setup_library_paths { } # Define list of directories containing crossbuilt libraries. if ($multiarch) { - push @librarypaths, "/lib/$multiarch", "/usr/lib/$multiarch"; + push @system_librarypaths, "/lib/$multiarch", "/usr/lib/$multiarch"; } - push @librarypaths, DEFAULT_LIBRARY_PATH; + 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'; parse_crle(); - push @librarypaths, DEFAULT_MULTILIB_PATH; + push @system_librarypaths, DEFAULT_MULTILIB_PATH; $librarypaths_init = 1; } @@ -153,13 +159,13 @@ sub add_library_dir { setup_library_paths() if not $librarypaths_init; - unshift @librarypaths, $dir; + push @custom_librarypaths, $dir; } sub get_library_paths { setup_library_paths() if not $librarypaths_init; - return @librarypaths; + return (@custom_librarypaths, @system_librarypaths); } # find_library ($soname, \@rpath, $format, $root) @@ -168,29 +174,24 @@ sub find_library { setup_library_paths() if not $librarypaths_init; + my @librarypaths = (@{$rpath}, @custom_librarypaths, @system_librarypaths); + my @libs; + $root //= ''; $root =~ s{/+$}{}; - my @rpath = @{$rpath}; - foreach my $dir (@rpath, @librarypaths) { + foreach my $dir (@librarypaths) { my $checkdir = "$root$dir"; - # If the directory checked is a symlink, check if it doesn't - # resolve to another public directory (which is then the canonical - # directory to use instead of this one). Typical example - # is /usr/lib64 -> /usr/lib on amd64. - if (-l $checkdir) { - my $newdir = resolve_symlink($checkdir); - if (any { "$root$_" eq "$newdir" } (@rpath, @librarypaths)) { - $checkdir = $newdir; - } - } if (-e "$checkdir/$lib") { my $libformat = Dpkg::Shlibs::Objdump::get_format("$checkdir/$lib"); if ($format eq $libformat) { - return canonpath("$checkdir/$lib"); + 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; + return @libs; } 1; diff --git a/scripts/Dpkg/Shlibs/Objdump.pm b/scripts/Dpkg/Shlibs/Objdump.pm index c19c3fbd7..91cc06488 100644 --- a/scripts/Dpkg/Shlibs/Objdump.pm +++ b/scripts/Dpkg/Shlibs/Objdump.pm @@ -83,40 +83,150 @@ sub has_object { return exists $self->{objects}{$objid}; } +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_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, $objdump) = @_; + my ($file) = @_; state %format; - $objdump //= $OBJDUMP; + return $format{$file} if exists $format{$file}; - if (exists $format{$file}) { - return $format{$file}; - } else { - my ($output, %opts, $pid, $res); - local $_; + my $header; - if ($objdump ne 'objdump') { - $opts{error_to_file} = '/dev/null'; - } - $pid = spawn(exec => [ $objdump, '-a', '--', $file ], - env => { LC_ALL => 'C' }, - to_pipe => \$output, %opts); - while (<$output>) { - chomp; - if (/^\s*\S+:\s*file\s+format\s+(\S+)\s*$/) { - $format{$file} = $1; - $res = $format{$file}; - last; - } - } - close($output); - wait_child($pid, nocheck => 1); - if ($?) { - subprocerr('objdump') if $objdump eq 'objdump'; - $res = get_format($file, 'objdump'); - } - return $res; + 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; + + # 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 { @@ -181,6 +291,13 @@ sub analyze { $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; + } + local $ENV{LC_ALL} = 'C'; open(my $objdump, '-|', $OBJDUMP, '-w', '-f', '-p', '-T', '-R', $file) or syserr(g_('cannot fork for %s'), $OBJDUMP); @@ -194,8 +311,8 @@ sub parse_objdump_output { my $section = 'none'; while (<$fh>) { - chomp; - next if /^\s*$/; + s/\s*$//; + next if length == 0; if (/^DYNAMIC SYMBOL TABLE:/) { $section = 'dynsym'; @@ -221,7 +338,7 @@ sub parse_objdump_output { if ($section eq 'dynsym') { $self->parse_dynamic_symbol($_); } elsif ($section eq 'dynreloc') { - if (/^\S+\s+(\S+)\s+(\S+)\s*$/) { + if (/^\S+\s+(\S+)\s+(.+)$/) { $self->{dynrelocs}{$2} = $1; } else { warning(g_("couldn't parse dynamic relocation record: %s"), $_); @@ -248,9 +365,9 @@ sub parse_objdump_output { } } } elsif ($section eq 'none') { - if (/^\s*.+:\s*file\s+format\s+(\S+)\s*$/) { + if (/^\s*.+:\s*file\s+format\s+(\S+)$/) { $self->{format} = $1; - } elsif (/^architecture:\s*\S+,\s*flags\s*\S+:\s*$/) { + } elsif (/^architecture:\s*\S+,\s*flags\s*\S+:$/) { # Parse 2 lines of "-f" # architecture: i386, flags 0x00000112: # EXEC_P, HAS_SYMS, D_PAGED @@ -296,10 +413,21 @@ sub parse_objdump_output { # (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) = @_; - my $vis_re = '(\.protected|\.hidden|\.internal|0x\S+)'; - if ($line =~ /^[0-9a-f]+ (.{7})\s+(\S+)\s+[0-9a-f]+(?:\s+(\S+))?(?:\s+$vis_re)?\s+(\S+)/) { + if ($line =~ $dynsym_re) { my ($flags, $sect, $ver, $vis, $name) = ($1, $2, $3, $4, $5); diff --git a/scripts/Dpkg/Shlibs/Symbol.pm b/scripts/Dpkg/Shlibs/Symbol.pm index 56bf17783..802681bf1 100644 --- a/scripts/Dpkg/Shlibs/Symbol.pm +++ b/scripts/Dpkg/Shlibs/Symbol.pm @@ -22,11 +22,11 @@ use warnings; our $VERSION = '0.01'; use Storable (); +use List::Util qw(any); use Dpkg::Gettext; use Dpkg::ErrorHandling; -use Dpkg::Util qw(:list); -use Dpkg::Arch qw(debarch_is_concerned debarch_to_cpuattrs); +use Dpkg::Arch qw(debarch_is_concerned debarch_to_abiattrs); use Dpkg::Version; use Dpkg::Shlibs::Cppfilt; @@ -298,7 +298,7 @@ sub arch_is_concerned { return 0 if defined $arch && defined $arches && !debarch_is_concerned($arch, split /[\s,]+/, $arches); - my ($bits, $endian) = debarch_to_cpuattrs($arch); + 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'} && @@ -473,7 +473,7 @@ sub mark_not_found_in_library { if ($self->{deprecated}) { # Bump deprecated if the symbol is optional so that it - # keeps reappering in the diff while it's missing + # 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; diff --git a/scripts/Dpkg/Shlibs/SymbolFile.pm b/scripts/Dpkg/Shlibs/SymbolFile.pm index 3a03e3003..04d22306c 100644 --- a/scripts/Dpkg/Shlibs/SymbolFile.pm +++ b/scripts/Dpkg/Shlibs/SymbolFile.pm @@ -201,34 +201,35 @@ sub _new_symbol { return (ref $base) ? $base->clone(@_) : $base->new(@_); } -# Parameter seen is only used for recursive calls +# Option state is only used for recursive calls. sub parse { - my ($self, $fh, $file, $seen, $obj_ref, $base_symbol) = @_; + my ($self, $fh, $file, %opts) = @_; + my $state = $opts{state} //= {}; - if (defined($seen)) { - return if exists $seen->{$file}; # Avoid include loops + if (defined $state) { + return if exists $state->{seen}{$file}; # Avoid include loops } else { $self->{file} = $file; - $seen = {}; + $state->{seen} = {}; } - $seen->{$file} = 1; + $state->{seen}{$file} = 1; - if (not ref($obj_ref)) { # Init ref to name of current object/lib - $$obj_ref = undef; + 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 ($$obj_ref)) { + 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) ? $1 : 0; - my $sym = _new_symbol($base_symbol, deprecated => $deprecated); + my $sym = _new_symbol($state->{base_symbol}, deprecated => $deprecated); if ($self->create_symbol($2, base => $sym)) { - $self->add_symbol($sym, $$obj_ref); + $self->add_symbol($sym, ${$state->{obj_ref}}); } else { warning(g_('failed to parse line in %s: %s'), $file, $_); } @@ -236,36 +237,39 @@ sub parse { 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($base_symbol); + $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", $seen, $obj_ref, $new_base_symbol); + $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}{$$obj_ref}{deps}}, "$1"; + push @{$self->{objects}{${$state->{obj_ref}}}{deps}}, "$1"; } elsif (/^\*\s*([^:]+):\s*(.*\S)\s*$/) { # Add meta-fields - $self->{objects}{$$obj_ref}{fields}{field_capitalize($1)} = $2; + $self->{objects}{${$state->{obj_ref}}}{fields}{field_capitalize($1)} = $2; } elsif (/^(\S+)\s+(.*)$/) { # New object and dependency template - $$obj_ref = $1; - if (exists $self->{objects}{$$obj_ref}) { + ${$state->{obj_ref}} = $1; + if (exists $self->{objects}{${$state->{obj_ref}}}) { # Update/override infos only - $self->{objects}{$$obj_ref}{deps} = [ "$2" ]; + $self->{objects}{${$state->{obj_ref}}}{deps} = [ "$2" ]; } else { # Create a new object - $self->create_object($$obj_ref, "$2"); + $self->create_object(${$state->{obj_ref}}, "$2"); } } else { warning(g_('failed to parse a line in %s: %s'), $file, $_); } } - delete $seen->{$file}; + delete $state->{seen}{$file}; } # Beware: we reuse the data structure of the provided symfile so make @@ -368,7 +372,7 @@ sub find_matching_pattern { if (my $alias = $converter->convert_to_alias($name)) { if ($alias && exists $aliases->{$alias}) { $pattern = $aliases->{$alias}; - last if &$pattern_ok($pattern); + last if $pattern_ok->($pattern); $pattern = undef; # otherwise not found yet } } @@ -378,7 +382,7 @@ sub find_matching_pattern { # 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)) { + if ($pattern_ok->($p) && $p->matches_rawname($name)) { $pattern = $p; last; } @@ -406,7 +410,7 @@ sub merge_symbols { my %include_groups = (); my $groups = $self->get_field($soname, 'Ignore-Blacklist-Groups'); if (defined $groups) { - $include_groups{$_} = 1 foreach (split /\s+/, $groups); + $include_groups{$_} = 1 foreach (split ' ', $groups); } my %dynsyms; diff --git a/scripts/Dpkg/Source/Archive.pm b/scripts/Dpkg/Source/Archive.pm index 2af113af3..33c181b20 100644 --- a/scripts/Dpkg/Source/Archive.pm +++ b/scripts/Dpkg/Source/Archive.pm @@ -26,6 +26,7 @@ use File::Basename qw(basename); use File::Spec; use Cwd; +use Dpkg (); use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::IPC; @@ -46,11 +47,14 @@ sub create { $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} = [ 'tar', '--null', '-T', '-', '--numeric-owner', - '--owner', '0', '--group', '0', '--format=gnu', - @{$opts{options}}, '-cf', '-' ]; + $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(); } @@ -126,8 +130,8 @@ sub extract { # Call tar extraction process $spawn_opts{delete_env} = [ 'TAR_OPTIONS' ]; - $spawn_opts{exec} = [ 'tar', '--no-same-owner', '--no-same-permissions', - @{$opts{options}}, '-xf', '-' ]; + $spawn_opts{exec} = [ $Dpkg::PROGTAR, '-xf', '-', '--no-same-permissions', + '--no-same-owner', @{$opts{options}} ]; spawn(%spawn_opts); $self->close(); diff --git a/scripts/Dpkg/Source/Functions.pm b/scripts/Dpkg/Source/Functions.pm index b44b06f0b..0a940463e 100644 --- a/scripts/Dpkg/Source/Functions.pm +++ b/scripts/Dpkg/Source/Functions.pm @@ -27,7 +27,7 @@ our @EXPORT_OK = qw( ); use Exporter qw(import); -use POSIX qw(:errno_h); +use Errno qw(ENOENT); use Dpkg::ErrorHandling; use Dpkg::Gettext; diff --git a/scripts/Dpkg/Source/Package.pm b/scripts/Dpkg/Source/Package.pm index 000984e17..f7851d203 100644 --- a/scripts/Dpkg/Source/Package.pm +++ b/scripts/Dpkg/Source/Package.pm @@ -34,7 +34,7 @@ is the one that supports the extraction of the source package. use strict; use warnings; -our $VERSION = '1.01'; +our $VERSION = '1.02'; our @EXPORT_OK = qw( get_default_diff_ignore_regex set_default_diff_ignore_regex @@ -67,10 +67,10 @@ my $diff_ignore_default_regex = ' # Ignore baz-style junk files or directories (?:^|/),,.*(?:$|/.*$)| # File-names that should be ignored (never directories) -(?:^|/)(?:DEADJOE|\.arch-inventory|\.(?:bzr|cvs|hg|git)ignore)$| +(?:^|/)(?: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)?| +\.hg(?:tags|sigs)?|_darcs|\.git(?:attributes|modules|review)?| \.mailmap|\.shelf|_MTN|\.be|\.bzr(?:\.backup|tags)?)(?:$|/.*$) '; # Take out comments and newlines @@ -106,11 +106,13 @@ our @tar_ignore_default_pattern = qw( .gitattributes .gitignore .gitmodules +.gitreview .hg .hgignore .hgsigs .hgtags .mailmap +.mtn-ignore .shelf .svn CVS @@ -126,7 +128,7 @@ _darcs =over 4 -=item my $string = get_default_diff_ignore_regex() +=item $string = get_default_diff_ignore_regex() Returns the default diff ignore regex. @@ -148,7 +150,7 @@ sub set_default_diff_ignore_regex { $diff_ignore_default_regex = $regex; } -=item my @array = get_default_tar_ignore_pattern() +=item @array = get_default_tar_ignore_pattern() Returns the default tar ignore pattern, as an array. @@ -187,6 +189,11 @@ specific for source packages using format "2.0" and "3.0 (quilt)". 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 @@ -223,14 +230,18 @@ sub init_options { # 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'; + push @{$self->{options}{tar_ignore}}, + 'debian/source/local-options', + 'debian/source/local-patch-header', + 'debian/files', + 'debian/files.new'; # Skip debianization while specific to some formats has an impact # on code common to all formats $self->{options}{skip_debianization} //= 0; @@ -274,17 +285,23 @@ sub upgrade_object_type { my $format = $self->{fields}{'Format'}; if ($format =~ /^([\d\.]+)(?:\s+\((.*)\))?$/) { - my ($version, $variant, $major, $minor) = ($1, $2, $1, undef); + my ($version, $variant) = ($1, $2); if (defined $variant and $variant ne lc $variant) { error(g_("source package format '%s' is not supported: %s"), $format, g_('format variant must be in lowercase')); } - $major =~ s/\.[\d\.]+$//; + my $major = $version =~ s/\.[\d\.]+$//r; + my $minor; + my $module = "Dpkg::Source::Package::V$major"; $module .= '::' . ucfirst $variant if defined $variant; - eval "require $module; \$minor = \$${module}::CURRENT_MINOR_VERSION;"; + eval qq{ + pop \@INC if \$INC[-1] eq '.'; + require $module; + \$minor = \$${module}::CURRENT_MINOR_VERSION; + }; $minor //= 0; if ($update_format) { $self->{fields}{'Format'} = "$major.$minor"; @@ -294,6 +311,7 @@ sub upgrade_object_type { error(g_("source package format '%s' is not supported: %s"), $format, $@); } + $module->prerequisites() if $module->can('prerequisites'); bless $self, $module; } else { error(g_("invalid Format field '%s'"), $format); @@ -327,17 +345,32 @@ sub get_files { 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. +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 { @@ -413,7 +446,7 @@ sub check_signature { if (length $ENV{HOME} and -r "$ENV{HOME}/.gnupg/trustedkeys.gpg") { push @exec, '--keyring', "$ENV{HOME}/.gnupg/trustedkeys.gpg"; } - foreach my $vendor_keyring (run_vendor_hook('keyrings')) { + foreach my $vendor_keyring (run_vendor_hook('package-keyrings')) { if (-r $vendor_keyring) { push @exec, '--keyring', $vendor_keyring; } @@ -439,13 +472,17 @@ sub check_signature { } } else { if ($self->{options}{require_valid_signature}) { - error(g_("could not verify signature on %s since gpg isn't installed"), $dsc); + error(g_('cannot verify signature on %s since GnuPG is not installed'), $dsc); } else { - warning(g_("could not verify signature on %s since gpg isn't installed"), $dsc); + warning(g_('cannot verify signature on %s since GnuPG is not installed'), $dsc); } } } +sub describe_cmdline_options { + return; +} + sub parse_cmdline_options { my ($self, @opts) = @_; foreach my $option (@opts) { @@ -462,7 +499,8 @@ sub parse_cmdline_option { =item $p->extract($targetdir) Extracts the source package in the target directory $targetdir. Beware -that if $targetdir already exists, it will be erased. +that if $targetdir already exists, it will be erased (as long as the +no_overwrite_dir option is set). =cut @@ -566,7 +604,7 @@ sub do_build { sub can_build { my ($self, $dir) = @_; - return (0, 'can_build() has not been overriden'); + return (0, 'can_build() has not been overridden'); } sub add_file { @@ -604,12 +642,12 @@ sub write_dsc { } unless ($opts{nocheck}) { - foreach my $f (qw(Source Version)) { + 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 Architecture Standards-Version)) { + foreach my $f (qw(Maintainer Standards-Version)) { unless (defined($fields->{$f})) { warning(g_('missing information for output field %s'), $f); } @@ -633,6 +671,10 @@ sub write_dsc { =head1 CHANGES +=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(), @@ -644,10 +686,6 @@ Deprecated variables: $diff_ignore_default_regexp, @tar_ignore_default_pattern Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog, E<lt>hertzog@debian.orgE<gt> - =cut 1; diff --git a/scripts/Dpkg/Source/Package/V1.pm b/scripts/Dpkg/Source/Package/V1.pm index db81962d7..001d9ecd3 100644 --- a/scripts/Dpkg/Source/Package/V1.pm +++ b/scripts/Dpkg/Source/Package/V1.pm @@ -21,7 +21,7 @@ use warnings; our $VERSION = '0.01'; -use POSIX qw(:errno_h); +use Errno qw(ENOENT); use Cwd; use File::Basename; use File::Temp qw(tempfile); @@ -36,6 +36,7 @@ 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); @@ -51,8 +52,12 @@ sub init_options { } else { $self->{options}{diff_ignore_regex} = '(?:^|/)debian/source/local-.*$'; } - push @{$self->{options}{tar_ignore}}, 'debian/source/local-options', - 'debian/source/local-patch-header'; + $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; @@ -64,6 +69,66 @@ sub init_options { $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}; @@ -104,10 +169,13 @@ sub do_extract { # 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 { @@ -129,7 +197,11 @@ sub do_extract { my $expectprefix = $newdirectory; $expectprefix .= '.orig'; - erasedir($newdirectory); + 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, @@ -282,6 +354,7 @@ sub do_build { } my ($tarname, $tardirname, $tardirbase); + my $tarsign; if ($sourcestyle ne 'n') { my ($origdirname, $origdirbase) = fileparse($origdir); @@ -294,6 +367,7 @@ sub do_build { $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)'), @@ -304,9 +378,9 @@ sub do_build { if ($sourcestyle eq 'n') { $self->{options}{ARGV} = []; # ensure we have no error Dpkg::Source::Package::V3::Native::do_build($self, $dir); - } elsif ($sourcestyle =~ m/[nurUR]/) { + } elsif ($sourcestyle =~ m/[urUR]/) { if (stat($tarname)) { - unless ($sourcestyle =~ m/[nUR]/) { + unless ($sourcestyle =~ m/[UR]/) { error(g_("tarfile '%s' already exists, not overwriting, " . 'giving up; use -sU or -sR to override'), $tarname); } @@ -336,6 +410,10 @@ sub do_build { } $self->add_file($tarname) if $tarname; + if ($tarname and -e "$tarname.sig" and not -e "$tarname.asc") { + openpgp_sig_to_asc("$tarname.sig", "$tarname.asc"); + } + $self->add_file($tarsign) if $tarsign and -e $tarsign; if ($sourcestyle =~ m/[kpKP]/) { if (stat($origdir)) { @@ -403,8 +481,7 @@ sub do_build { } if ($ur) { - printf { *STDERR } g_('%s: unrepresentable changes to source') . "\n", - $Dpkg::PROGNAME; + errormsg(g_('unrepresentable changes to source')); exit(1); } } diff --git a/scripts/Dpkg/Source/Package/V2.pm b/scripts/Dpkg/Source/Package/V2.pm index e27758ef7..818e32ddc 100644 --- a/scripts/Dpkg/Source/Package/V2.pm +++ b/scripts/Dpkg/Source/Package/V2.pm @@ -21,7 +21,6 @@ use warnings; our $VERSION = '0.01'; -use POSIX qw(:errno_h); use List::Util qw(first); use Cwd; use File::Basename; @@ -43,6 +42,7 @@ use Dpkg::Source::Functions qw(erasedir is_binary 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); @@ -63,6 +63,58 @@ sub init_options { $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') { @@ -156,7 +208,11 @@ sub do_extract { if $addonfile{$name} ne substr $addonsign{$name}, 0, -4; } - erasedir($newdirectory); + 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); @@ -172,6 +228,10 @@ sub do_extract { 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); @@ -187,22 +247,10 @@ sub do_extract { # Extract debian tarball after removing the debian directory info(g_('unpacking %s'), $debianfile); erasedir("$newdirectory/debian"); - # Exclude existing symlinks from extraction of debian.tar.gz as we - # don't want to overwrite something outside of $newdirectory due to a - # symlink - my @exclude_symlinks; - my $wanted = sub { - return if not -l; - my $fn = File::Spec->abs2rel($_, $newdirectory); - push @exclude_symlinks, '--exclude', $fn; - }; - find({ wanted => $wanted, no_chdir => 1 }, $newdirectory); $tar = Dpkg::Source::Archive->new(filename => "$dscdir$debianfile"); - $tar->extract($newdirectory, in_place => 1, - options => [ '--anchored', '--no-wildcards', - @exclude_symlinks ]); + $tar->extract($newdirectory, in_place => 1); - # Apply patches (in a separate method as it might be overriden) + # Apply patches (in a separate method as it might be overridden) $self->apply_patches($newdirectory, usage => 'unpack') unless $self->{options}{skip_patches}; } @@ -211,7 +259,7 @@ sub get_autopatch_name { return 'zz_debian-diff-auto'; } -sub get_patches { +sub _get_patches { my ($self, $dir, %opts) = @_; $opts{skip_auto} //= 0; my @patches; @@ -233,14 +281,14 @@ sub get_patches { sub apply_patches { my ($self, $dir, %opts) = @_; $opts{skip_auto} //= 0; - my @patches = $self->get_patches($dir, %opts); + 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)) { + 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); @@ -254,7 +302,7 @@ sub apply_patches { sub unapply_patches { my ($self, $dir, %opts) = @_; - my @patches = reverse($self->get_patches($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); @@ -269,7 +317,7 @@ sub unapply_patches { unlink($applied); } -sub upstream_tarball_template { +sub _upstream_tarball_template { my $self = shift; my $ext = '{' . join(',', sort map { @@ -284,7 +332,7 @@ sub can_build { 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())); + $self->_upstream_tarball_template())); } sub before_build { @@ -342,7 +390,7 @@ sub check_patches_applied { } } -sub generate_patch { +sub _generate_patch { my ($self, $dir, %opts) = @_; my ($dirname, $updir) = fileparse($dir); my $basedirname = $self->get_basename(); @@ -361,15 +409,23 @@ sub generate_patch { $tarfile = $file; push @origtarballs, $file; $self->add_file($file); + if (-e "$file.sig" and not -e "$file.asc") { + openpgp_sig_to_asc("$file.sig", "$file.asc"); + } + $self->add_file("$file.asc") if -e "$file.asc"; } elsif ($file =~ /\.orig-([[:alnum:]-]+)\.tar\.$comp_ext_regex$/) { $addonfile{$1} = $file; push @origtarballs, $file; $self->add_file($file); + if (-e "$file.sig" and not -e "$file.asc") { + openpgp_sig_to_asc("$file.sig", "$file.asc"); + } + $self->add_file("$file.asc") if -e "$file.asc"; } } error(g_('no upstream tarball found at %s'), - $self->upstream_tarball_template()) unless $tarfile; + $self->_upstream_tarball_template()) unless $tarfile; if ($opts{usage} eq 'build') { info(g_('building %s using existing %s'), @@ -413,7 +469,7 @@ sub generate_patch { my $analysis = $header_from->analyze($dir, verbose => 0); $diff->set_header($analysis->{patchheader}); } else { - $diff->set_header($self->get_patch_header($dir)); + $diff->set_header($self->_get_patch_header($dir)); } $diff->add_diff_directory($tmp, $dir, basedirname => $basedirname, %{$self->{diff_options}}, @@ -517,7 +573,7 @@ sub do_build { # Create a patch my $autopatch = File::Spec->catfile($dir, 'debian', 'patches', $self->get_autopatch_name()); - my $tmpdiff = $self->generate_patch($dir, order_from => $autopatch, + my $tmpdiff = $self->_generate_patch($dir, order_from => $autopatch, header_from => $autopatch, handle_binary => $handle_binary, skip_auto => $self->{options}{auto_commit}, @@ -558,7 +614,7 @@ sub do_build { $self->add_file($debianfile); } -sub get_patch_header { +sub _get_patch_header { my ($self, $dir) = @_; my $ph = File::Spec->catfile($dir, 'debian', 'source', 'local-patch-header'); unless (-f $ph) { @@ -584,6 +640,8 @@ 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); + $text = "$header"; run_vendor_hook('extend-patch-header', \$text, $ch_info); $text .= "\n--- @@ -597,7 +655,7 @@ 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"; +Last-Update: $yyyy_mm_dd\n\n"; return $text; } @@ -656,7 +714,7 @@ sub do_commit { }; unless ($tmpdiff) { - $tmpdiff = $self->generate_patch($dir, handle_binary => $handle_binary, + $tmpdiff = $self->_generate_patch($dir, handle_binary => $handle_binary, usage => 'commit'); $binaryfiles->update_debian_source_include_binaries(); } @@ -670,7 +728,9 @@ sub do_commit { # Ask the patch name interactively print g_('Enter the desired patch name: '); $patch_name = <STDIN>; - next unless defined $patch_name; + 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; @@ -694,7 +754,8 @@ package Dpkg::Source::Package::V2::BinaryFiles; use Dpkg::ErrorHandling; use Dpkg::Gettext; -use File::Path; +use File::Path qw(make_path); +use File::Spec; sub new { my ($this, $dir) = @_; diff --git a/scripts/Dpkg/Source/Package/V3/Bzr.pm b/scripts/Dpkg/Source/Package/V3/Bzr.pm index 6cf8fae26..f0752c0b1 100644 --- a/scripts/Dpkg/Source/Package/V3/Bzr.pm +++ b/scripts/Dpkg/Source/Package/V3/Bzr.pm @@ -36,23 +36,20 @@ 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 import { - foreach my $dir (split(/:/, $ENV{PATH})) { - if (-x "$dir/bzr") { - return 1; - } - } +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 { +sub _sanity_check { my $srcdir = shift; if (! -d "$srcdir/.bzr") { @@ -106,7 +103,7 @@ sub do_build { my $basedirname = $basename; $basedirname =~ s/_/-/; - sanity_check($dir); + _sanity_check($dir); my $old_cwd = getcwd(); chdir $dir or syserr(g_("unable to chdir to '%s'"), $dir); @@ -188,14 +185,18 @@ sub do_extract { "$basenamerev.bzr.tar.$comp_ext_regex", $tarfile); } - erasedir($newdirectory); + 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); + _sanity_check($newdirectory); my $old_cwd = getcwd(); chdir($newdirectory) diff --git a/scripts/Dpkg/Source/Package/V3/Custom.pm b/scripts/Dpkg/Source/Package/V3/Custom.pm index 4895897aa..63f176913 100644 --- a/scripts/Dpkg/Source/Package/V3/Custom.pm +++ b/scripts/Dpkg/Source/Package/V3/Custom.pm @@ -27,6 +27,18 @@ 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=(.*)$/) { diff --git a/scripts/Dpkg/Source/Package/V3/Git.pm b/scripts/Dpkg/Source/Package/V3/Git.pm index 97b7aff70..a915807b0 100644 --- a/scripts/Dpkg/Source/Package/V3/Git.pm +++ b/scripts/Dpkg/Source/Package/V3/Git.pm @@ -31,6 +31,7 @@ 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); @@ -45,17 +46,13 @@ delete $ENV{GIT_OBJECT_DIRECTORY}; delete $ENV{GIT_ALTERNATE_OBJECT_DIRECTORIES}; delete $ENV{GIT_WORK_TREE}; -sub import { - foreach my $dir (split(/:/, $ENV{PATH})) { - if (-x "$dir/git") { - return 1; - } - } +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 { +sub _sanity_check { my $srcdir = shift; if (! -d "$srcdir/.git") { @@ -71,6 +68,26 @@ sub sanity_check { 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); @@ -99,7 +116,7 @@ sub do_build { my ($dirname, $updir) = fileparse($dir); my $basenamerev = $self->get_basename(1); - sanity_check($dir); + _sanity_check($dir); my $old_cwd = getcwd(); chdir $dir or syserr(g_("unable to chdir to '%s'"), $dir); @@ -215,7 +232,11 @@ sub do_extract { error(g_('format v3.0 (git) expected %s'), "$basenamerev.git"); } - erasedir($newdirectory); + 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); @@ -230,7 +251,7 @@ sub do_extract { subprocerr('cp') if $?; } - sanity_check($newdirectory); + _sanity_check($newdirectory); } 1; diff --git a/scripts/Dpkg/Source/Package/V3/Native.pm b/scripts/Dpkg/Source/Package/V3/Native.pm index ea38c2740..b53a30f3f 100644 --- a/scripts/Dpkg/Source/Package/V3/Native.pm +++ b/scripts/Dpkg/Source/Package/V3/Native.pm @@ -58,7 +58,12 @@ sub do_extract { error(g_('no tarfile in Files field')) unless $tarfile; - erasedir($newdirectory); + 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); diff --git a/scripts/Dpkg/Source/Package/V3/Quilt.pm b/scripts/Dpkg/Source/Package/V3/Quilt.pm index 497076d4e..9718ffa2d 100644 --- a/scripts/Dpkg/Source/Package/V3/Quilt.pm +++ b/scripts/Dpkg/Source/Package/V3/Quilt.pm @@ -20,12 +20,12 @@ 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::Util qw(:list); use Dpkg::Version; use Dpkg::Source::Patch; use Dpkg::Source::Functions qw(erasedir fs_time); @@ -45,6 +45,26 @@ sub init_options { $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); @@ -60,7 +80,7 @@ sub parse_cmdline_option { return 0; } -sub build_quilt_object { +sub _build_quilt_object { my ($self, $dir) = @_; return $self->{quilt}{$dir} if exists $self->{quilt}{$dir}; $self->{quilt}{$dir} = Dpkg::Source::Quilt->new($dir); @@ -76,7 +96,7 @@ sub can_build { return (0, g_('non-native package version does not contain a revision')) if $v->is_native(); - my $quilt = $self->build_quilt_object($dir); + my $quilt = $self->_build_quilt_object($dir); $msg = $quilt->find_problems(); return (0, $msg) if $msg; return 1; @@ -101,7 +121,7 @@ sub apply_patches { $opts{verbose} = 0; } - my $quilt = $self->build_quilt_object($dir); + 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 @@ -146,7 +166,7 @@ sub apply_patches { sub unapply_patches { my ($self, $dir, %opts) = @_; - my $quilt = $self->build_quilt_object($dir); + my $quilt = $self->_build_quilt_object($dir); $opts{verbose} //= 1; @@ -179,7 +199,7 @@ sub prepare_build { sub do_build { my ($self, $dir) = @_; - my $quilt = $self->build_quilt_object($dir); + my $quilt = $self->_build_quilt_object($dir); my $version = $quilt->get_db_version(); if (defined($version) and $version != 2) { @@ -197,7 +217,7 @@ sub do_build { sub after_build { my ($self, $dir) = @_; - my $quilt = $self->build_quilt_object($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') { @@ -209,13 +229,13 @@ sub after_build { sub check_patches_applied { my ($self, $dir) = @_; - my $quilt = $self->build_quilt_object($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); + return unless $patch_obj->check_apply($dir, fatal_dupes => 1); $self->apply_patches($dir, usage => 'preparation', verbose => 1); } @@ -223,7 +243,7 @@ sub check_patches_applied { sub register_patch { my ($self, $dir, $tmpdiff, $patch_name) = @_; - my $quilt = $self->build_quilt_object($dir); + my $quilt = $self->_build_quilt_object($dir); my $patch = $quilt->get_patch_file($patch_name); if (-s $tmpdiff) { diff --git a/scripts/Dpkg/Source/Patch.pm b/scripts/Dpkg/Source/Patch.pm index dbc0fa7b7..e5ad5424b 100644 --- a/scripts/Dpkg/Source/Patch.pm +++ b/scripts/Dpkg/Source/Patch.pm @@ -30,6 +30,7 @@ use File::Compare; use Fcntl ':mode'; use Time::HiRes qw(stat); +use Dpkg; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::IPC; @@ -112,7 +113,7 @@ sub add_diff_file { while (<$diffgen>) { if (m/^(?:binary|[^-+\@ ].*\bdiffer\b)/i) { $binary = 1; - &$handle_binary($self, $old, $new, %opts); + $handle_binary->($self, $old, $new, %opts); last; } elsif (m/^[-+\@ ]/) { $difflinefound++; @@ -161,7 +162,7 @@ sub add_diff_directory { my %files_in_new; my $scan_new = sub { my $fn = (length > length($new)) ? substr($_, length($new) + 1) : '.'; - return if &$diff_ignore($fn); + 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]); @@ -221,7 +222,7 @@ sub add_diff_directory { }; my $scan_old = sub { my $fn = (length > length($old)) ? substr($_, length($old) + 1) : '.'; - return if &$diff_ignore($fn); + 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 _) { @@ -491,8 +492,15 @@ sub analyze { } if ($filepatched{$fn}) { - warning(g_("diff '%s' patches file %s twice"), $diff, $fn) - if $opts{verbose}; + $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; @@ -575,7 +583,7 @@ sub apply { $self->ensure_open('r'); my ($stdout, $stderr) = ('', ''); spawn( - exec => [ 'patch', @{$opts{options}} ], + exec => [ $Dpkg::PROGPATCH, @{$opts{options}} ], chdir => $destdir, env => { LC_ALL => 'C', LANG => 'C', PATCH_GET => '0' }, delete_env => [ 'POSIXLY_CORRECT' ], # ensure expected patch behaviour @@ -588,7 +596,7 @@ sub apply { if ($?) { print { *STDOUT } $stdout; print { *STDERR } $stderr; - subprocerr('LC_ALL=C patch ' . join(' ', @{$opts{options}}) . + subprocerr("LC_ALL=C $Dpkg::PROGPATCH " . join(' ', @{$opts{options}}) . ' < ' . $self->get_filename()); } $self->close(); @@ -625,7 +633,7 @@ sub check_apply { # Apply the patch $self->ensure_open('r'); my $patch_pid = spawn( - exec => [ 'patch', @{$opts{options}} ], + exec => [ $Dpkg::PROGPATCH, @{$opts{options}} ], chdir => $destdir, env => { LC_ALL => 'C', LANG => 'C', PATCH_GET => '0' }, delete_env => [ 'POSIXLY_CORRECT' ], # ensure expected patch behaviour @@ -635,7 +643,7 @@ sub check_apply { ); wait_child($patch_pid, nocheck => 1); my $exit = WEXITSTATUS($?); - subprocerr('patch --dry-run') unless WIFEXITED($?); + subprocerr("$Dpkg::PROGPATCH --dry-run") unless WIFEXITED($?); $self->close(); return ($exit == 0); } diff --git a/scripts/Dpkg/Source/Quilt.pm b/scripts/Dpkg/Source/Quilt.pm index a07abb20b..55b3fbaf8 100644 --- a/scripts/Dpkg/Source/Quilt.pm +++ b/scripts/Dpkg/Source/Quilt.pm @@ -20,6 +20,7 @@ use warnings; our $VERSION = '0.02'; +use List::Util qw(any none); use File::Spec; use File::Copy; use File::Find; @@ -28,7 +29,6 @@ use File::Basename; use Dpkg::Gettext; use Dpkg::ErrorHandling; -use Dpkg::Util qw(:list); use Dpkg::Source::Patch; use Dpkg::Source::Functions qw(erasedir fs_time); use Dpkg::Vendor qw(get_current_vendor); diff --git a/scripts/Dpkg/Substvars.pm b/scripts/Dpkg/Substvars.pm index b3cb714ad..1e9f90173 100644 --- a/scripts/Dpkg/Substvars.pm +++ b/scripts/Dpkg/Substvars.pm @@ -19,13 +19,11 @@ package Dpkg::Substvars; use strict; use warnings; -our $VERSION = '1.04'; - -use POSIX qw(:errno_h); -use Carp; +our $VERSION = '1.06'; use Dpkg (); use Dpkg::Arch qw(get_host_arch); +use Dpkg::Version; use Dpkg::ErrorHandling; use Dpkg::Gettext; @@ -49,14 +47,14 @@ strings. use constant { SUBSTVAR_ATTR_USED => 1, SUBSTVAR_ATTR_AUTO => 2, - SUBSTVAR_ATTR_OLD => 4, + SUBSTVAR_ATTR_AGED => 4, }; =head1 METHODS =over 8 -=item my $s = Dpkg::Substvars->new($file) +=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} @@ -179,7 +177,10 @@ Obsolete function, use mark_as_used() instead. sub no_warn { my ($self, $key) = @_; - carp 'obsolete no_warn() function, use mark_as_used() instead'; + + warnings::warnif('deprecated', + 'obsolete no_warn() function, use mark_as_used() instead'); + $self->mark_as_used($key); } @@ -192,10 +193,13 @@ Add new substitutions read from $file. 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); @@ -207,7 +211,10 @@ sub parse { $varlistfile, $.); } $self->set($1, $2); + $count++; } + + return $count } =item $s->set_version_substvars($sourceversion, $binaryversion) @@ -229,8 +236,11 @@ sub set_version_substvars { # field on the changelog, always fix up the source version. $sourceversion =~ s/\+b[0-9]+$//; - my $upstreamversion = $sourceversion; - $upstreamversion =~ s/-[^-]*$//; + 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; @@ -238,8 +248,8 @@ sub set_version_substvars { $self->set('source:Version', $sourceversion, $attr); $self->set('source:Upstream-Version', $upstreamversion, $attr); - # XXX: Source-Version is now deprecated, remove in the future. - $self->set('Source-Version', $binaryversion, $attr | SUBSTVAR_ATTR_OLD); + # 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() @@ -258,6 +268,43 @@ sub set_arch_substvars { $self->set('Arch', get_host_arch(), $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. @@ -290,9 +337,9 @@ sub substvars { $self->mark_as_used($vn); $count++; - if (not $opts{no_warn} and $self->{attr}{$vn} & SUBSTVAR_ATTR_OLD) { - warning($opts{msg_prefix} . - g_('deprecated substitution variable ${%s}'), $vn); + if ($self->{attr}{$vn} & SUBSTVAR_ATTR_AGED) { + error($opts{msg_prefix} . + g_('obsolete substitution variable ${%s}'), $vn); } } else { warning($opts{msg_prefix} . g_('unknown substitution variable ${%s}'), @@ -313,7 +360,7 @@ sub warn_about_unused { my ($self, %opts) = @_; $opts{msg_prefix} //= $self->{msg_prefix}; - foreach my $vn (keys %{$self->{vars}}) { + 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 @@ -337,10 +384,11 @@ sub set_msg_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. +that return true when $rmfunc->($key) or $keepfunc->($key) is called. =cut @@ -351,7 +399,7 @@ sub filter { my $keep = $opts{keep} // sub { 1 }; foreach my $vn (keys %{$self->{vars}}) { - $self->delete($vn) if &$remove($vn) or not &$keep($vn); + $self->delete($vn) if $remove->($vn) or not $keep->($vn); } } @@ -389,6 +437,18 @@ sub output { =head1 CHANGES +=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(). @@ -414,10 +474,6 @@ New method: $s->set_as_used(). Mark the module as public. -=head1 AUTHOR - -Raphaël Hertzog <hertzog@debian.org>. - =cut 1; diff --git a/scripts/Dpkg/Util.pm b/scripts/Dpkg/Util.pm deleted file mode 100644 index 4b371a115..000000000 --- a/scripts/Dpkg/Util.pm +++ /dev/null @@ -1,59 +0,0 @@ -# Copyright © 2013, 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::Util; - -use strict; -use warnings; - -our $VERSION = '0.01'; -our @EXPORT_OK = qw( - any - none -); -our %EXPORT_TAGS = ( - list => [ qw(any none) ], -); - -use Exporter qw(import); - -# XXX: Ideally we would use List::MoreUtils, but that's not a core module, -# so to avoid the additional dependency we'll make do with the following -# trivial reimplementations. -# -# These got added to List::Util 1.33, which got merged into perl 5.20.0, -# once that is in Debian oldstable we can switch to that core module. - -sub any(&@) { - my $code = shift; - - foreach (@_) { - return 1 if $code->(); - } - - return 0; -} - -sub none(&@) { - my $code = shift; - - foreach (@_) { - return 0 if $code->(); - } - - return 1; -} - -1; diff --git a/scripts/Dpkg/Vendor.pm b/scripts/Dpkg/Vendor.pm index fcb2d3fdd..196159156 100644 --- a/scripts/Dpkg/Vendor.pm +++ b/scripts/Dpkg/Vendor.pm @@ -34,7 +34,7 @@ use Exporter qw(import); use Dpkg (); use Dpkg::ErrorHandling; use Dpkg::Gettext; -use Dpkg::BuildEnv; +use Dpkg::Build::Env; use Dpkg::Control::HashCore; my $origins = "$Dpkg::CONFDIR/origins"; @@ -61,13 +61,16 @@ the relationship by listing the base distribution in the Parent field: Parent: Debian -The file should be named according to the vendor name. +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 = Dpkg::Vendor::get_vendor_dir() +=item $dir = get_vendor_dir() Returns the current dpkg origins directory name, where the vendor files are stored. @@ -78,7 +81,7 @@ sub get_vendor_dir { return $origins; } -=item $fields = Dpkg::Vendor::get_vendor_info($name) +=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, @@ -96,12 +99,12 @@ sub get_vendor_info(;$) { my $file = get_vendor_file($vendor); return unless $file; my $fields = Dpkg::Control::HashCore->new(); - $fields->load($file) or error(g_('%s is empty'), $file); + $fields->load($file, compression => 0) or error(g_('%s is empty'), $file); $VENDOR_CACHE{$vendor} = $fields; return $fields; } -=item $name = Dpkg::Vendor::get_vendor_file($name) +=item $name = get_vendor_file($name) Check if there's a file for the given vendor and returns its name. @@ -121,7 +124,7 @@ sub get_vendor_file(;$) { return $file; } -=item $name = Dpkg::Vendor::get_current_vendor() +=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. @@ -131,8 +134,8 @@ If that file doesn't exist, it returns undef. sub get_current_vendor() { my $f; - if (Dpkg::BuildEnv::has('DEB_VENDOR')) { - $f = get_vendor_info(Dpkg::BuildEnv::get('DEB_VENDOR')); + 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(); @@ -140,7 +143,7 @@ sub get_current_vendor() { return; } -=item $object = Dpkg::Vendor::get_vendor_object($name) +=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. @@ -159,6 +162,7 @@ sub get_vendor_object { foreach my $name (@names) { eval qq{ + pop \@INC if \$INC[-1] eq '.'; require Dpkg::Vendor::$name; \$obj = Dpkg::Vendor::$name->new(); }; @@ -176,7 +180,7 @@ sub get_vendor_object { } } -=item Dpkg::Vendor::run_vendor_hook($hookid, @params) +=item run_vendor_hook($hookid, @params) Run a hook implemented by the current vendor object. @@ -199,6 +203,10 @@ New function: get_vendor_dir(). Mark the module as public. +=head1 SEE ALSO + +deb-origin(5). + =cut 1; diff --git a/scripts/Dpkg/Vendor/Debian.pm b/scripts/Dpkg/Vendor/Debian.pm index 52917cd94..e0fd01113 100644 --- a/scripts/Dpkg/Vendor/Debian.pm +++ b/scripts/Dpkg/Vendor/Debian.pm @@ -1,5 +1,5 @@ # Copyright © 2009-2011 Raphaël Hertzog <hertzog@debian.org> -# Copyright © 2009, 2011-2015 Guillem Jover <guillem@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> @@ -25,11 +25,10 @@ use warnings; our $VERSION = '0.01'; +use Dpkg; use Dpkg::Gettext; use Dpkg::ErrorHandling; use Dpkg::Control::Types; -use Dpkg::BuildOptions; -use Dpkg::Arch qw(get_host_arch debarch_to_debtriplet); use parent qw(Dpkg::Vendor::Default); @@ -41,17 +40,28 @@ Dpkg::Vendor::Debian - Debian vendor object =head1 DESCRIPTION -This vendor object customize the behaviour of dpkg scripts -for Debian specific actions. +This vendor object customizes the behaviour of dpkg scripts for Debian +specific behavior and policies. =cut sub run_hook { my ($self, $hook, @params) = @_; - if ($hook eq 'keyrings') { + if ($hook eq 'package-keyrings') { return ('/usr/share/keyrings/debian-keyring.gpg', '/usr/share/keyrings/debian-maintainers.gpg'); + } elsif ($hook eq 'keyrings') { + warnings::warnif('deprecated', 'deprecated keyrings vendor hook'); + return $self->run_hook('package-keyrings', @params); + } elsif ($hook eq 'archive-keyrings') { + return ('/usr/share/keyrings/debian-archive-keyring.gpg'); + } elsif ($hook eq 'archive-keyrings-historic') { + 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; @@ -68,62 +78,100 @@ sub run_hook { $$textref .= "Bug-Ubuntu: https://bugs.launchpad.net/bugs/$bug\n"; } } elsif ($hook eq 'update-buildflags') { - $self->_add_qa_flags(@params); - $self->_add_reproducible_flags(@params); - $self->_add_sanitize_flags(@params); - $self->_add_hardening_flags(@params); + $self->_add_build_flags(@params); + } elsif ($hook eq 'builtin-system-build-paths') { + return qw(/build/); } else { return $self->SUPER::run_hook($hook, @params); } } -sub _parse_build_options { - my ($self, $variable, $area, $use_feature) = @_; - - # Adjust features based on user or maintainer's desires. - my $opts = Dpkg::BuildOptions->new(envvar => $variable); - foreach my $feature (split(/,/, $opts->get($area) // '')) { - $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'), - $area, $variable, $feature); - } - } - } else { - warning(g_('incorrect value in %s option of %s variable: %s'), - $area, $variable, $feature); - } - } -} - sub _parse_feature_area { my ($self, $area, $use_feature) = @_; - $self->_parse_build_options('DEB_BUILD_OPTIONS', $area, $use_feature); - $self->_parse_build_options('DEB_BUILD_MAINT_OPTIONS', $area, $use_feature); + require Dpkg::BuildOptions; + + # Adjust features based on user or maintainer's desires. + my $opts = Dpkg::BuildOptions->new(envvar => 'DEB_BUILD_OPTIONS'); + $opts->parse_features($area, $use_feature); + $opts = Dpkg::BuildOptions->new(envvar => 'DEB_BUILD_MAINT_OPTIONS'); + $opts->parse_features($area, $use_feature); } -sub _add_qa_flags { +sub _add_build_flags { my ($self, $flags) = @_; # Default feature states. my %use_feature = ( - bug => 0, - canary => 0, + future => { + lfs => 0, + }, + qa => { + bug => 0, + canary => 0, + }, + reproducible => { + timeless => 1, + fixdebugpath => 1, + }, + 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, + }, ); + my %builtin_feature = ( + hardening => { + pie => 1, + }, + ); + + ## Setup + # Adjust features based on user or maintainer's desires. - $self->_parse_feature_area('qa', \%use_feature); + foreach my $area (sort keys %use_feature) { + $self->_parse_feature_area($area, $use_feature{$area}); + } + + require Dpkg::Arch; + + my $arch = Dpkg::Arch::get_host_arch(); + 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) = ('', '', ''); + } + + ## 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{bug}) { + if ($use_feature{qa}{bug}) { foreach my $warnflag (qw(array-bounds clobbered volatile-register-var implicit-function-declaration)) { $flags->append('CFLAGS', "-Werror=$warnflag"); @@ -132,7 +180,7 @@ sub _add_qa_flags { } # Inject dummy canary options to detect issues with build flag propagation. - if ($use_feature{canary}) { + if ($use_feature{qa}{canary}) { require Digest::MD5; my $id = Digest::MD5::md5_hex(int rand 4096); @@ -142,149 +190,144 @@ sub _add_qa_flags { $flags->append('LDFLAGS', "-Wl,-z,deb-canary-${id}"); } - # Store the feature usage. - while (my ($feature, $enabled) = each %use_feature) { - $flags->set_feature('qa', $feature, $enabled); - } -} + ## Area: reproducible -sub _add_reproducible_flags { - my ($self, $flags) = @_; + my $build_path; - # Default feature states. - my %use_feature = ( - timeless => 0, - ); + # Mask features that might have an unsafe usage. + if ($use_feature{reproducible}{fixdebugpath}) { + require Cwd; - # Adjust features based on user or maintainer's desires. - $self->_parse_feature_area('reproducible', \%use_feature); + $build_path = $ENV{DEB_BUILD_PATH} || Cwd::cwd(); + + # If we have any unsafe character in the path, disable the flag, + # so that we do not need to worry about escaping the characters + # on output. + if ($build_path =~ m/[^-+:.0-9a-zA-Z~\/_]/) { + $use_feature{fixdebugpath} = 0; + } + } # Warn when the __TIME__, __DATE__ and __TIMESTAMP__ macros are used. - if ($use_feature{timeless}) { + if ($use_feature{reproducible}{timeless}) { $flags->append('CPPFLAGS', '-Wdate-time'); } - # Store the feature usage. - while (my ($feature, $enabled) = each %use_feature) { - $flags->set_feature('reproducible', $feature, $enabled); + # Avoid storing the build path in the debug symbols. + if ($use_feature{reproducible}{fixdebugpath}) { + my $map = '-fdebug-prefix-map=' . $build_path . '=.'; + $flags->append('CFLAGS', $map); + $flags->append('CXXFLAGS', $map); + $flags->append('OBJCFLAGS', $map); + $flags->append('OBJCXXFLAGS', $map); + $flags->append('FFLAGS', $map); + $flags->append('FCFLAGS', $map); + $flags->append('GCJFLAGS', $map); } -} -sub _add_sanitize_flags { - my ($self, $flags) = @_; - - # Default feature states. - my %use_feature = ( - address => 0, - thread => 0, - leak => 0, - undefined => 0, - ); - - # Adjust features based on user or maintainer's desires. - $self->_parse_feature_area('sanitize', \%use_feature); + ## Area: sanitize # Handle logical feature interactions. - if ($use_feature{address} or $use_feature{thread}) { + 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{leak} = 0; + $use_feature{sanitize}{leak} = 0; } - if ($use_feature{address}) { + 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{thread}) { + if ($use_feature{sanitize}{thread}) { my $flag = '-fsanitize=thread'; $flags->append('CFLAGS', $flag); $flags->append('CXXFLAGS', $flag); $flags->append('LDFLAGS', $flag); } - if ($use_feature{leak}) { + if ($use_feature{sanitize}{leak}) { $flags->append('LDFLAGS', '-fsanitize=leak'); } - if ($use_feature{undefined}) { + if ($use_feature{sanitize}{undefined}) { my $flag = '-fsanitize=undefined'; $flags->append('CFLAGS', $flag); $flags->append('CXXFLAGS', $flag); $flags->append('LDFLAGS', $flag); } - # Store the feature usage. - while (my ($feature, $enabled) = each %use_feature) { - $flags->set_feature('sanitize', $feature, $enabled); - } -} - -sub _add_hardening_flags { - my ($self, $flags) = @_; - my $arch = get_host_arch(); - my ($abi, $os, $cpu) = debarch_to_debtriplet($arch); - - unless (defined $abi and defined $os and defined $cpu) { - warning(g_("unknown host architecture '%s'"), $arch); - ($abi, $os, $cpu) = ('', '', ''); - } + ## Area: hardening - # Default feature states. - my %use_feature = ( - pie => 0, - stackprotector => 1, - stackprotectorstrong => 1, - fortify => 1, - format => 1, - relro => 1, - bindnow => 0, + # Mask builtin features that are not enabled by default in the compiler. + my %builtin_pie_arch = map { $_ => 1 } qw( + amd64 arm64 armel armhf i386 kfreebsd-amd64 kfreebsd-i386 + mips mipsel mips64el powerpc ppc64 ppc64el s390x sparc sparc64 ); - - # Adjust features based on user or maintainer's desires. - $self->_parse_feature_area('hardening', \%use_feature); + if (not exists $builtin_pie_arch{$arch}) { + $builtin_feature{hardening}{pie} = 0; + } # Mask features that are not available on certain architectures. - if ($os !~ /^(?:linux|knetbsd|hurd)$/ or + if ($os !~ /^(?:linux|kfreebsd|knetbsd|hurd)$/ or $cpu =~ /^(?:hppa|avr32)$/) { - # Disabled on non-linux/knetbsd/hurd (see #430455 and #586215). + # Disabled on non-(linux/kfreebsd/knetbsd/hurd). # Disabled on hppa, avr32 # (#574716). - $use_feature{pie} = 0; + $use_feature{hardening}{pie} = 0; } - if ($cpu =~ /^(?:ia64|alpha|hppa)$/ or $arch eq 'arm') { - # Stack protector disabled on ia64, alpha, hppa. + 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{stackprotector} = 0; + $use_feature{hardening}{stackprotector} = 0; } if ($cpu =~ /^(?:ia64|hppa|avr32)$/) { # relro not implemented on ia64, hppa, avr32. - $use_feature{relro} = 0; + $use_feature{hardening}{relro} = 0; } # Mask features that might be influenced by other flags. if ($flags->{build_options}->has('noopt')) { # glibc 2.16 and later warn when using -O0 and _FORTIFY_SOURCE. - $use_feature{fortify} = 0; + $use_feature{hardening}{fortify} = 0; } # Handle logical feature interactions. - if ($use_feature{relro} == 0) { + 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{bindnow} = 0; + $use_feature{hardening}{bindnow} = 0; } - if ($use_feature{stackprotector} == 0) { + if ($use_feature{hardening}{stackprotector} == 0) { # Disable stackprotectorstrong if stackprotector is disabled. - $use_feature{stackprotectorstrong} = 0; + $use_feature{hardening}{stackprotectorstrong} = 0; } # PIE - if ($use_feature{pie}) { - my $flag = '-fPIE'; + 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('CFLAGS', $flag); + $flags->append('OBJCFLAGS', $flag); + $flags->append('OBJCXXFLAGS', $flag); + $flags->append('FFLAGS', $flag); + $flags->append('FCFLAGS', $flag); + $flags->append('CXXFLAGS', $flag); + $flags->append('GCJFLAGS', $flag); + $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('CFLAGS', $flag); $flags->append('OBJCFLAGS', $flag); $flags->append('OBJCXXFLAGS', $flag); @@ -292,11 +335,11 @@ sub _add_hardening_flags { $flags->append('FCFLAGS', $flag); $flags->append('CXXFLAGS', $flag); $flags->append('GCJFLAGS', $flag); - $flags->append('LDFLAGS', '-fPIE -pie'); + $flags->append('LDFLAGS', "-specs=$Dpkg::DATADIR/no-pie-link.specs"); } # Stack protector - if ($use_feature{stackprotectorstrong}) { + if ($use_feature{hardening}{stackprotectorstrong}) { my $flag = '-fstack-protector-strong'; $flags->append('CFLAGS', $flag); $flags->append('OBJCFLAGS', $flag); @@ -305,7 +348,7 @@ sub _add_hardening_flags { $flags->append('FCFLAGS', $flag); $flags->append('CXXFLAGS', $flag); $flags->append('GCJFLAGS', $flag); - } elsif ($use_feature{stackprotector}) { + } elsif ($use_feature{hardening}{stackprotector}) { my $flag = '-fstack-protector --param=ssp-buffer-size=4'; $flags->append('CFLAGS', $flag); $flags->append('OBJCFLAGS', $flag); @@ -317,12 +360,12 @@ sub _add_hardening_flags { } # Fortify Source - if ($use_feature{fortify}) { + if ($use_feature{hardening}{fortify}) { $flags->append('CPPFLAGS', '-D_FORTIFY_SOURCE=2'); } # Format Security - if ($use_feature{format}) { + if ($use_feature{hardening}{format}) { my $flag = '-Wformat -Werror=format-security'; $flags->append('CFLAGS', $flag); $flags->append('CXXFLAGS', $flag); @@ -331,18 +374,29 @@ sub _add_hardening_flags { } # Read-only Relocations - if ($use_feature{relro}) { + if ($use_feature{hardening}{relro}) { $flags->append('LDFLAGS', '-Wl,-z,relro'); } # Bindnow - if ($use_feature{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. - while (my ($feature, $enabled) = each %use_feature) { - $flags->set_feature('hardening', $feature, $enabled); + foreach my $area (sort keys %use_feature) { + while (my ($feature, $enabled) = each %{$use_feature{$area}}) { + $flags->set_feature($area, $feature, $enabled); + } } } diff --git a/scripts/Dpkg/Vendor/Default.pm b/scripts/Dpkg/Vendor/Default.pm index a9c6a6412..40815efde 100644 --- a/scripts/Dpkg/Vendor/Default.pm +++ b/scripts/Dpkg/Vendor/Default.pm @@ -39,9 +39,9 @@ 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 guaranty to be stable over an -extended period. If you run an important distribution that makes use -of vendor hooks, you'd better submit them for integration so that +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 @@ -75,12 +75,38 @@ supported hooks are: The first parameter is a Dpkg::Source::Package object. The hook is called just before the execution of $srcpkg->build(). -=item keyrings () +=item package-keyrings () The hook is called when dpkg-source is checking a signature on a source -package. It takes no parameters, but returns a (possibly empty) list of +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. @@ -104,6 +130,16 @@ 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 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. + =back =cut @@ -114,15 +150,28 @@ sub run_hook { if ($hook eq 'before-source-build') { my $srcpkg = shift @params; } elsif ($hook eq 'keyrings') { + warnings::warnif('deprecated', 'obsolete keyrings vendor hook'); + return (); + } elsif ($hook eq 'package-keyrings') { + return (); + } elsif ($hook eq 'archive-keyrings') { + 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 'builtin-system-build-paths') { + return (); } # Default return value for unknown/unimplemented hooks diff --git a/scripts/Dpkg/Vendor/Ubuntu.pm b/scripts/Dpkg/Vendor/Ubuntu.pm index c6dff77ac..eb2dffefe 100644 --- a/scripts/Dpkg/Vendor/Ubuntu.pm +++ b/scripts/Dpkg/Vendor/Ubuntu.pm @@ -1,4 +1,4 @@ -# Copyright © 2008 Ian Jackson <ian@davenant.greenend.org.uk> +# 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> @@ -26,10 +26,7 @@ our $VERSION = '0.01'; use Dpkg::ErrorHandling; use Dpkg::Gettext; -use Dpkg::Path qw(find_command); use Dpkg::Control::Types; -use Dpkg::BuildOptions; -use Dpkg::Arch qw(debarch_eq get_host_arch); use parent qw(Dpkg::Vendor::Debian); @@ -41,8 +38,8 @@ Dpkg::Vendor::Ubuntu - Ubuntu vendor object =head1 DESCRIPTION -This vendor object customize the behaviour of dpkg-source -to check that Maintainers have been modified if necessary. +This vendor object customizes the behaviour of dpkg scripts for Ubuntu +specific behavior and policies. =cut @@ -70,11 +67,16 @@ sub run_hook { } } elsif ($hook eq 'keyrings') { - my @keyrings = $self->SUPER::run_hook($hook); - - push(@keyrings, '/usr/share/keyrings/ubuntu-archive-keyring.gpg'); - return @keyrings; - + return $self->run_hook('package-keyrings', @params); + } 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, @@ -95,10 +97,16 @@ sub run_hook { } elsif ($hook eq 'update-buildflags') { my $flags = shift @params; + + require Dpkg::BuildOptions; + my $build_opts = Dpkg::BuildOptions->new(); if (!$build_opts->has('noopt')) { - if (debarch_eq(get_host_arch(), 'ppc64el')) { + 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)) { $flags->set($flag, '-g -O3', 'vendor'); @@ -110,43 +118,6 @@ sub run_hook { # Run the Debian hook to add hardening flags $self->SUPER::run_hook($hook, $flags); - - # Allow control of hardening-wrapper via dpkg-buildpackage DEB_BUILD_OPTIONS - my $hardening; - if ($build_opts->has('hardening')) { - $hardening = $build_opts->get('hardening') // 1; - } - if ($build_opts->has('nohardening')) { - $hardening = 0; - } - if (defined $hardening) { - my $flag = 'DEB_BUILD_HARDENING'; - if ($hardening ne '0') { - if (!find_command('hardened-cc')) { - syserr(g_("'hardening' flag found but 'hardening-wrapper' not installed")); - } - if ($hardening ne '1') { - my @options = split(/,\s*/, $hardening); - $hardening = 1; - - my @hardopts = qw(format fortify stackprotector pie relro); - foreach my $item (@hardopts) { - my $upitem = uc($item); - foreach my $option (@options) { - if ($option =~ /^(no)?$item$/) { - $flags->set($flag . '_' . $upitem, - not defined $1 or $1 eq '', 'env'); - } - } - } - } - } - if (defined $ENV{$flag}) { - info(g_('overriding %s in environment: %s'), $flag, $hardening); - } - $flags->set($flag, $hardening, 'env'); - } - } else { return $self->SUPER::run_hook($hook, @params); } diff --git a/scripts/Dpkg/Version.pm b/scripts/Dpkg/Version.pm index 378216ce9..477082b67 100644 --- a/scripts/Dpkg/Version.pm +++ b/scripts/Dpkg/Version.pm @@ -1,5 +1,5 @@ # Copyright © Colin Watson <cjwatson@debian.org> -# Copyright © Ian Jackson <iwj@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> # @@ -52,8 +52,8 @@ use constant { }; use overload - '<=>' => \&comparison, - 'cmp' => \&comparison, + '<=>' => \&_comparison, + 'cmp' => \&_comparison, '""' => sub { return $_[0]->as_string(); }, 'bool' => sub { return $_[0]->as_string() if $_[0]->is_valid(); }, 'fallback' => 1; @@ -76,7 +76,7 @@ them. =over 4 -=item my $v = Dpkg::Version->new($version, %opts) +=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 @@ -175,7 +175,7 @@ its string representation is a version number. =cut -sub comparison { +sub _comparison { my ($a, $b, $inverted) = @_; if (not ref($b) or not $b->isa('Dpkg::Version')) { $b = Dpkg::Version->new($b); @@ -278,7 +278,7 @@ sub version_compare_relation($$$) { } } -=item my $rel = version_normalize_relation($rel_string) +=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 @@ -316,7 +316,7 @@ 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-Za-z) +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. @@ -380,7 +380,7 @@ sub version_compare_part($$) { } } -=item my @items = version_split_digits($version) +=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 @@ -394,9 +394,9 @@ sub version_split_digits($) { return split /(?<=\d)(?=\D)|(?<=\D)(?=\d)/, $version; } -=item my ($ok, $msg) = version_check($version) +=item ($ok, $msg) = version_check($version) -=item my $ok = 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 @@ -416,6 +416,21 @@ sub version_check($) { 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; @@ -450,12 +465,6 @@ New method: $v->is_native(). Mark the module as public. -=head1 AUTHOR - -Don Armstrong <don@donarmstrong.com>, Colin Watson -<cjwatson@debian.org> and Raphaël Hertzog <hertzog@debian.org>, based on -the implementation in F<dpkg/lib/version.c> by Ian Jackson and others. - =cut 1; |