[libconfig-model-dpkg-perl] 06/07: cleanup old lower-than dependencies (Closes: #871422)
dod at debian.org
dod at debian.org
Mon Aug 21 17:54:31 UTC 2017
This is an automated email from the git hooks/post-receive script.
dod pushed a commit to branch master
in repository libconfig-model-dpkg-perl.
commit 01fa03dcb4f79c4320ede5ebff976008d955d782
Author: Dominique Dumont <dod at debian.org>
Date: Fri Aug 18 19:43:10 2017 +0200
cleanup old lower-than dependencies (Closes: #871422)
Althigh this also impacts dual life dependencies
---
lib/Config/Model/Dpkg/Dependency.pm | 85 ++++++++++++++++++++++---------
t/dependency-check.t | 45 +++++++++++++++-
t/model_tests.d/dpkg-control-test-conf.pl | 7 ++-
3 files changed, 110 insertions(+), 27 deletions(-)
diff --git a/lib/Config/Model/Dpkg/Dependency.pm b/lib/Config/Model/Dpkg/Dependency.pm
index 481c798..e949f26 100644
--- a/lib/Config/Model/Dpkg/Dependency.pm
+++ b/lib/Config/Model/Dpkg/Dependency.pm
@@ -420,7 +420,6 @@ sub struct_to_dep {
my $self = shift ;
my @input = @_ ;
- my $skip = 0 ;
my @alternatives ;
foreach my $d (@input) {
my $line = '';
@@ -431,8 +430,6 @@ sub struct_to_dep {
if ( $name) {
$line .= $name;
- # skip test for relations like << or <
- $skip ++ if defined $dep->[0] and $dep->[0] =~ /</ ;
$line .= " (@$dep)" if defined $dep->[1];
$line .= " [@$arch]" if $arch;
@@ -452,7 +449,7 @@ sub struct_to_dep {
my $actual_dep = @alternatives ? join (' | ', at alternatives) : undef ;
- return wantarray ? ($actual_dep, $skip) : $actual_dep ;
+ return $actual_dep ;
}
# @input contains the alternates dependencies (without '|') of one dependency values
@@ -462,17 +459,12 @@ sub struct_to_dep {
sub check_depend_chain {
my ($self, $apply_fix, $input, $old, $msgs) = @_ ;
- my ($actual_dep, $skip) = $self->struct_to_dep (@$input);
+ my $actual_dep = $self->struct_to_dep (@$input);
my $ret = 1 ;
return 1 unless defined $actual_dep; # may have been cleaned during fix
$logger->debug("called with $actual_dep with apply_fix $apply_fix");
- if ($skip) {
- $logger->debug("skipping '$actual_dep': has a < relation ship") ;
- return $ret ;
- }
-
foreach my $depend (@$input) {
if (ref ($depend)) {
# is a dependency (not a variable a la ${perl-Depends})
@@ -513,7 +505,8 @@ sub check_perl_lib_dep {
$logger->debug("called for $dep_name with $actual_dep with apply_fix $apply_fix");
my ($old_perl_dep) = grep { $_->{name} eq 'perl' } @$input;
- my $old_perl_versioned_dep = $old_perl_dep->{dep}[1];
+ my $old_perl_versioned_op = $old_perl_dep->{dep}[0] ;
+ my $old_perl_versioned_dep = $old_perl_dep->{dep}[1] ;
# The dependency should be in the form perl (>= 5.10.1) | libtest-simple-perl (>= 0.88)".
# cf http://pkg-perl.alioth.debian.org/policy.html#debian_control_handling
@@ -533,11 +526,10 @@ sub check_perl_lib_dep {
my $removed = Module::CoreList->removed_from($cpan_name) ;
$logger->debug("dual life $dep_name is removed from perl $removed") if $removed;
- return 1 if (defined $dep_v && $dep_v =~ m/^\$/) ; # version like ${foobar}
+ return 1 if (defined $dep_v && $dep_v =~ m/^\$/) ; # version like ${foobar} in lib dep
- my %ideal_perl_dep = qw/name perl/ ;
+ my %ideal_perl_dep ;
my %ideal_lib_dep ;
- my @ideal_dep_chain = (\%ideal_perl_dep);
my @res = $self->get_available_version( $dep_name);
@@ -592,8 +584,31 @@ sub check_perl_lib_dep {
}
my ($has_older_perl) = $self->check_versioned_dep( { name => 'perl', dep => ['>=', $v_normal]} );
- $ideal_perl_dep{dep} = [ '>=', $v_normal ] if $has_older_perl;
+ if ((not defined $old_perl_versioned_op or $old_perl_versioned_op =~ />/) and not $deprecated) {
+ $ideal_perl_dep{name} = 'perl';
+ if ( $has_older_perl ) {
+ my $oper = $old_perl_versioned_op // '>=';
+ $logger->debug("Found older perl for a greater-than perl dep. Ideal perl dep is 'perl $oper $v_normal'");
+ $ideal_perl_dep{dep} = [ $oper, $v_normal ];
+ }
+ else {
+ $logger->debug("Did no find older perl for a greater-than perl dep. Ideal perl dep is plain 'perl'");
+ }
+ }
+
+ if (defined $old_perl_versioned_op and $old_perl_versioned_op =~ /</) {
+ if ( $has_older_perl ) {
+ $logger->debug("Found older perl for a lower-than perl dep. Ideal perl dep is 'perl $old_perl_versioned_op $v_normal'");
+ $ideal_perl_dep{name} = 'perl';
+ $ideal_perl_dep{dep} = [ $old_perl_versioned_op, $v_normal ];
+ }
+ else {
+ # e.g. perl (<< 5.8.0)m i.e. lower than obsolete perl -> remove dependency from ideal perl dep
+ $logger->debug("Did not find older perl for a lower-than perl dep. Perl dep should be removed");
+ }
+ }
+ # we assume that lib dep is always >= ...
if ($removed or $deprecated or $has_older_perl) {
my ($has_older_lib) = $self->check_versioned_dep( $depend );
$ideal_lib_dep{name} = $dep_name;
@@ -610,9 +625,9 @@ sub check_perl_lib_dep {
);
my @ordered_ideal_dep
- = $removed || $deprecated ? ( \%ideal_lib_dep )
- : $has_older_perl_in_sid ? ( \%ideal_perl_dep, \%ideal_lib_dep )
- : ( \%ideal_lib_dep, \%ideal_perl_dep ) ;
+ = $removed || $deprecated ? ( \%ideal_lib_dep, \%ideal_perl_dep )
+ : $has_older_perl_in_sid ? ( \%ideal_perl_dep, \%ideal_lib_dep )
+ : ( \%ideal_lib_dep, \%ideal_perl_dep ) ;
my $ideal_dep = $self->struct_to_dep( @ordered_ideal_dep );
@@ -622,7 +637,7 @@ sub check_perl_lib_dep {
if ( $actual_dep ne $ideal_dep ) {
my $msg = "Dependency of dual life package should be '$ideal_dep' not '$actual_dep'";
if ($apply_fix) {
- @$input = @ordered_ideal_dep ; # notify_change called in check_value
+ @$input = grep {defined $_->{name} } @ordered_ideal_dep ; # notify_change called in check_value
if ($logger->is_info) {
$logger->info("fixed dependency with: $ideal_dep, was ". $self->struct_to_dep($depend));
}
@@ -660,7 +675,6 @@ sub check_versioned_dep {
if ( @dist_version # no older for unknow packages
and defined $oper
- and $oper =~ />/
and $vers !~ /^\$/ # a dpkg variable
) {
my $src_pkg_name = $self->grab_value("!Dpkg::Control source Source") ;
@@ -690,7 +704,7 @@ sub has_older_version_than {
$logger->debug("$pkg $vers has_older is $has_older (@list)");
return 1 if $has_older ;
- return wantarray ? (0, at list) : 0 ;
+ return (0, at list) ;
}
#
@@ -787,7 +801,12 @@ sub check_or_fix_dep {
my ( $vers_dep_ok, @list ) = $self->check_versioned_dep( $dep_info );
return if $vers_dep_ok;
- $self->warn_or_remove_vers_dep ($apply_fix, $dep_info, \@list, $msgs) ;
+ if ($dep_info->{dep}[0] =~ /</) {
+ $self->warn_or_remove_dep ($apply_fix, $dep_info, \@list, $msgs) ;
+ }
+ else {
+ $self->warn_or_remove_vers_dep ($apply_fix, $dep_info, \@list, $msgs) ;
+ }
}
sub warn_or_remove_vers_dep {
@@ -797,8 +816,26 @@ sub warn_or_remove_vers_dep {
my $msg = "unnecessary greater-than versioned dependency: ". $self-> struct_to_dep($dep_info)
. ". Debian has @$list";
if ($apply_fix) {
- delete $dep_info->{dep}; # remove versioned dep, notify_change called in check_value
- $logger->info("fix: removed versioned dependency from $dep_info->{name} -> $pkg");
+ delete $dep_info->{dep}; # remove greater-than versioned dep, notify_change called in check_value
+ $logger->info("fix: removed greater-than versioned dependency from $pkg");
+ push $msgs->@*, $msg;
+ }
+ else {
+ $self->{nb_of_fixes}++;
+ $self->add_warning( $msg);
+ $logger->info("will warn: $msg (fix++)");
+ }
+}
+
+sub warn_or_remove_dep {
+ my ( $self, $apply_fix, $dep_info, $list, $msgs ) = @_;
+ my $pkg = $dep_info->{name};
+
+ my $msg = "unnecessary older-than versioned dependency: ". $self-> struct_to_dep($dep_info)
+ . ". Debian has @$list";
+ if ($apply_fix) {
+ %$dep_info = (); # remove whole dependency
+ $logger->info("fix: removed dependency $pkg");
push $msgs->@*, $msg;
}
else {
diff --git a/t/dependency-check.t b/t/dependency-check.t
index d688fdf..b575611 100644
--- a/t/dependency-check.t
+++ b/t/dependency-check.t
@@ -16,7 +16,9 @@ BEGIN {
'libsdl1.2' => '', # only source
'libmodule-metadata-perl' => 'wheezy 1.000009-1+deb7u1 jessie 1.000024-1 jessie-kfreebsd 1.000024-1 stretch 1.000024-1 sid 1.000024-1',
'libextutils-parsexs-perl' => 'squeeze 2.220600-1 wheezy 3.150000-1 jessie-kfreebsd 3.240000-1 jessie 3.240000-1 stretch 3.240000-1 sid 3.240000-1',
+ 'libtest-simple-perl' => 'etch 0.62-1 lenny 0.80-1 backports/lenny 0.94-1~bpo50+1 squeeze 0.94-1 wheezy 0.98-1 sid 0.98-1',
'dpkg' => 'squeeze 1.15 wheezy 1.16 sid 1.16',
+ 'libclass-isa-perl' => 'oldoldstable 0.36-3 oldstable 0.36-5 stable 0.36-5 testing 0.36-5 unstable 0.36-5 oldstable-kfreebsd 0.36-5',
makedev => 'squeeze 2.3.1-89 wheezy 2.3.1-92 jessie 2.3.1-92 sid 2.3.1-93',
udev => 'squeeze 164-3 wheezy 175-7.2 jessie 175-7.2 sid 175-7.2',
foobar => undef, # used to test that unknown package trigger a warning, real cache should not contain undef
@@ -203,6 +205,10 @@ warning_like {
my ($res) = $dep_value->check_versioned_dep( {name => 'perl', dep => ['>=','5.6.0']} );
is( $res, 0, "check perl (>= 5.6.0) dependency: no older version");
+# test that obsolete break type dependencies are removed (#871422)
+($res) = $dep_value->check_versioned_dep( {name => 'lcdproc', dep => [qw/<< 0.4.2/] } );
+is( $res, 0, "check lcdproc (<< 0.4.2) dependency: removed");
+
# $dep_value->store('libcpan-meta-perl') ;
# exit ;
@@ -216,6 +222,10 @@ my @chain_tests = (
=> [ { name => 'perl', dep => [qw/>= 5.10/]}, { name => 'libmodule-build-perl'}]
=> [ { name => 'libmodule-build-perl'}],
+ 'libmodule-build-perl perl-modules 5.10'
+ => [ { name => 'perl-modules', dep => [qw/>= 5.10/]}, { name => 'libmodule-build-perl'}]
+ => [ { name => 'libmodule-build-perl'}],
+
# test Debian #719225
'libarchive-extract-perl'
=> [ { name => 'libarchive-extract-perl', dep => [qw/>= 0.68/]} ,
@@ -238,7 +248,20 @@ my @chain_tests = (
'libmodule-parsexs-perl to fix'
=> [ { name => 'perl', dep => [qw/>= 5.12/]}, { name => 'libextutils-parsexs-perl'}]
=> 1 ,
-);
+
+ # test for #682730
+ 'module removed from corelist - 1 '
+ => [ { name => 'libclass-isa-perl'}, { name => 'perl', dep => [qw/<< 5.11.1-13/]} ]
+ => 1,
+ 'module removed from corelist - 2'
+ => [ { name => 'libclass-isa-perl'}, { name => 'perl', dep => [qw/<< 5.08.1-13/]} ]
+ => [ { name => 'libclass-isa-perl'} ],
+
+ 'module part of core perl forever'
+ => [ { name => 'libtest-simple-perl' } ]
+ => [ { name => 'perl' } ],
+
+ );
while (@chain_tests) {
my ($tag,$dep,$expect) = splice @chain_tests,0,3;
@@ -383,6 +406,26 @@ is($perl_bdi->fetch,"libmodule-build-perl","check fixed B-D-I dependency value")
print scalar $inst->list_changes,"\n" if $trace ;
is($inst->c_count, 1,"check that fixes are tracked with notify changes") ;
+# test that obsolete break type dependencies are removed (#871422)
+my $bin_breaks = $control->grab("binary:lcdproc-breaker Breaks");
+warning_like {
+ $bin_breaks->fetch_with_id(0)->store('lcdproc (<< 0.4.2)');
+} qr/unnecessary older-than versioned dependency/, "Breaks with obsolete version triggers a warning";
+
+# test fixes
+is($bin_breaks->fetch_with_id(0)->has_fixes,1, "test presence of fixes");
+
+{
+ local $Config::Model::Value::nowarning = 1 ;
+ $control->grab("binary:lcdproc-breaker")->apply_fixes;
+ ok(1,"apply_fixes on Breaks done");
+}
+is($bin_breaks->has_fixes,0, "test that fixes are gone");
+is($bin_breaks->has_warning,0,"check that warnings are gone");
+
+is($bin_breaks->fetch_with_id(0)->fetch,undef ,"check fixed Breaks dependency value");
+
+
my $expected_warn = qr/URL is not the canonical one for repositories hosted on Alioth/;
my @vcs_tests = (
[ 'Vcs-Browser', 'http://git.debian.org/?p=debian-med/r-cran-stringr.git;a=summary',
diff --git a/t/model_tests.d/dpkg-control-test-conf.pl b/t/model_tests.d/dpkg-control-test-conf.pl
index 3c73084..3b2d7b2 100644
--- a/t/model_tests.d/dpkg-control-test-conf.pl
+++ b/t/model_tests.d/dpkg-control-test-conf.pl
@@ -103,9 +103,12 @@ providing the following file:
{
name => 'sdlperl',
load => 'source Uploaders:2="Sam Hocevar (Debian packages) <sam at zoy.org>"',
- load_warnings => [ ( qr/Warning/) x 11 ],
+ load_warnings => [ ( qr/Warning/) x 12 ],
load_check => 'skip',
- check => { 'binary:libsdl-perl Depends:2' => '${misc:Depends}' },
+ check => {
+ 'binary:libsdl-perl Depends:2' => '${misc:Depends}',
+ 'binary:libsdl-perl Conflicts:2' => undef,
+ },
apply_fix => 1,
},
{
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libconfig-model-dpkg-perl.git
More information about the Pkg-perl-cvs-commits
mailing list