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 b97ac548cec4c9352bdbde74ce8f9ee28024e988 Author: Dominique Dumont <d...@debian.org> Date: Sat Mar 5 12:39:03 2016 +0100 Adapted dpendency checker to new madison api --- lib/Config/Model/Dpkg/Dependency.pm | 101 ++++++++++++++++++++++-------------- 1 file changed, 62 insertions(+), 39 deletions(-) diff --git a/lib/Config/Model/Dpkg/Dependency.pm b/lib/Config/Model/Dpkg/Dependency.pm index 268d5eb..57a9db5 100644 --- a/lib/Config/Model/Dpkg/Dependency.pm +++ b/lib/Config/Model/Dpkg/Dependency.pm @@ -7,6 +7,9 @@ use Config::Model 2.066; # for show_message use Mouse; use URI::Escape; +use feature qw/postderef signatures/; +no warnings qw/experimental::postderef experimental::signatures/; + # Debian only module use lib '/usr/share/lintian/lib' ; use Lintian::Relation ; @@ -14,6 +17,7 @@ use Lintian::Relation ; use DB_File ; use Log::Log4perl qw(get_logger :levels); use Module::CoreList; +use JSON; use version ; use Parse::RecDescent ; @@ -26,6 +30,9 @@ use AptPkg::Version; use AptPkg::Cache ; use LWP::Simple ; +my $madison_host = 'api.ftp-master.debian.org'; +my $madison_endpoint = "https://$madison_host/madison"; + # list of virtual packages # See https://www.debian.org/doc/packaging-manuals/virtual-package-names-list.txt # updated from 30 Jul 2014 version @@ -299,8 +306,9 @@ sub check_dependency { # see http://www.debian.org/doc/debian-policy/ch-relationships.html - # to get package list - # wget -q -O - 'http://qa.debian.org/cgi-bin/madison.cgi?package=perl-doc&text=on' + # to get package list in json format ( 'f' option) + # wget -q -O - 'https://api.ftp-master.debian.org/madison?package=perl-doc&f' + # MOJO_USERAGENT_DEBUG=0 mojo get 'https://api.ftp-master.debian.org/madison?package=perl-doc&f' my @dep_chain ; if (defined $value) { @@ -527,9 +535,11 @@ sub check_perl_lib_dep { my $check_v = $dep_v ; # use oldest version only if the oldest version is NOT in oldstable - # unfortunately this is fragile and must be modified after each Debian - # release - if ($oldest_debian_with_lib =~ /wheezy|jessie|stretch|buster|sid/) { + # second test can be removed end of April 2016 (cache expiry) + # but cached data for tests must be modified to respect the new convention + if ( $oldest_debian_with_lib !~ /oldstable/ + or $oldest_debian_with_lib =~ /wheezy|jessie|stretch|buster|sid/ + ) { $check_v ||= $oldest_lib_version_in_debian ; $logger->debug("dual life $dep_name has oldest debian $oldest_lib_version_in_debian, using $check_v"); } @@ -568,12 +578,13 @@ sub check_perl_lib_dep { push @ideal_lib_dep, '>=', $dep_v if $dep_v and $has_older_lib; } - my %perl_version = $self->get_available_version( 'perl'); - my $has_older_perl_in_sid = ( $vs->compare( $v_normal, $perl_version{sid} ) < 0 ) ? 1 : 0; - $logger->debug( + my %perl_version = $self->get_available_version( 'perl'); + my $sid_perl_version = $perl_version{unstable} || $perl_version{sid} ; + my $has_older_perl_in_sid = ( $vs->compare( $v_normal, $sid_perl_version) < 0 ) ? 1 : 0; + $logger->debug( "perl $v_normal is", $has_older_perl_in_sid ? ' ' : ' not ', - "older than perl in sid ($perl_version{sid})" + "older than perl in sid ($sid_perl_version)" ); my @ordered_ideal_dep @@ -812,25 +823,24 @@ sub get_available_version { return @res; } - my $url = "http://qa.debian.org/cgi-bin/madison.cgi?package=".uri_escape($pkg_name)."&text=on" ; - $self->instance->show_message("Connecting to qa.debian.org to check $pkg_name versions. Please wait...") ; + my $url = "$madison_endpoint?package=".uri_escape($pkg_name).'&f' ; + $self->instance->show_message("Connecting to $madison_host to check $pkg_name versions. Please wait...") ; my $body = get($url); + my $res ; + if (defined $body) { + my $ref = extract_madison_info($body); + $self->instance->show_message("got info for $pkg_name") ; + $res = $ref->{$pkg_name} || []; + $logger->debug("pkg info is @$res"); + } + else { + warn "cannot get data for package $pkg_name. Check your proxy ?\n" unless defined $body ; + } - warn "cannot get data for package $pkg_name. Check your proxy ?\n" unless defined $body ; - - @res = (); - foreach my $line (split /\n/, $body) { - $line =~ s/^\s+|\s+$//g; - my ($name,$available_v,$dist,$type) = split /\s*\|\s*/, $line ; - $type =~ s/\s//g ; - push @res , $dist, $available_v unless $type eq 'source'; - } - $self->instance->show_message("got info for $pkg_name") ; - $cache{$pkg_name} = time ." @res" ; - $logger->debug("pkg info is ".$cache{$pkg_name}); - return @res; + return $res->@*; } + # this function queries *once* madison for package info not found in cache. # it should be called once when parsing control file sub cache_info_from_madison { @@ -857,28 +867,41 @@ sub cache_info_from_madison { return; } - my $url = "http://qa.debian.org/cgi-bin/madison.cgi?package=".join('+',map { uri_escape($_) } @needed)."&text=on" ; + my $url = "$madison_endpoint?package=".uri_escape(join(' ',@needed)).'&f' ; $instance->show_message( - "Connecting to qa.debian.org to check ", scalar @needed, " package versions. Please wait..." + "Connecting to $madison_host to check ", scalar @needed, " package versions. Please wait..." ); my $body = get($url); - warn "cannot get data from madison. Check your proxy ?\n" unless defined $body ; + if (defined $body) { + my $res = extract_madison_info($body); + $instance->show_message( "Got info from $madison_host for ", scalar keys %$res, " packages.") ; + } + else { + warn "cannot get data from madison. Check your proxy ?\n"; + } +} - my %res ; - foreach my $line (split /\n/, $body) { - $line =~ s/^\s+|\s+$//g; - my ($name,$available_v,$dist,$type) = split /\s*\|\s*/, $line ; - $type =~ s/\s//g ; - $res{$name} ||= [] ; - push @{$res{$name}} , $dist, $available_v unless $type eq 'source'; - } - $instance->show_message( "Got info from qa.debian.org for $necessary packages.") ; - foreach my $pname (keys %res) { - $cache{$pname} = time ." ".join(' ',@{$res{$pname}}) ; +# See https://ftp-master.debian.org/epydoc/dakweb.queries.madison-module.html +sub extract_madison_info ($json) { + my %ref ; + my $json_data = decode_json($json); + my $data = $json_data->[0] ; + + foreach my $name ( keys $data->%* ) { + my %avail; + foreach my $dist (keys $data->{$name}->%*) { + foreach my $available_v (keys $data->{$name}{$dist}->%*) { + $avail{$available_v} = $dist; + } + } + my @res = map { ($avail{$_}, $_) ; } sort { $vs->compare($a,$b) } keys %avail ; + $ref{$name} = \@res ; + $cache{$name} = join(' ',time, @res) ; } -} + return \%ref; +} __PACKAGE__->meta->make_immutable; -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libconfig-model-dpkg-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits