[libconfig-model-dpkg-perl] 01/02: Adapted dpendency checker to new madison api
dod at debian.org
dod at debian.org
Sat Mar 5 13:41:06 UTC 2016
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 <dod at 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(' ', at 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
More information about the Pkg-perl-cvs-commits
mailing list