[libconfig-model-dpkg-perl] 02/03: Dpkg::Dependency: added global function cache_info_from_madison
dod at debian.org
dod at debian.org
Thu Jan 30 18:47:22 UTC 2014
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 83180446db524e33ec80222b59fd09db68792ec0
Author: Dominique Dumont <dod at debian.org>
Date: Thu Jan 30 19:29:56 2014 +0100
Dpkg::Dependency: added global function cache_info_from_madison
---
lib/Config/Model/Dpkg/Dependency.pm | 61 +++++++++++++++++++++++++++++++++++++
1 file changed, 61 insertions(+)
diff --git a/lib/Config/Model/Dpkg/Dependency.pm b/lib/Config/Model/Dpkg/Dependency.pm
index 5916cce..f114ca6 100644
--- a/lib/Config/Model/Dpkg/Dependency.pm
+++ b/lib/Config/Model/Dpkg/Dependency.pm
@@ -16,6 +16,7 @@ use version ;
use Parse::RecDescent ;
+use AnyEvent;
use AnyEvent::HTTP ;
# available only in debian. Black magic snatched from
@@ -806,6 +807,7 @@ sub get_available_version {
if ($hdr->{Status} =~ /^2/) {
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 ;
push @res , $dist, $available_v unless $type eq 'source';
@@ -823,6 +825,65 @@ sub get_available_version {
);
}
+# this function queries *once* madison for package info not found in cache.
+# it should be called once when parding control file
+sub cache_info_from_madison {
+ my ($callback, at pkg_names) = @_ ;
+
+ $async_log->debug("called on @pkg_names");
+
+ my $necessary = 0;
+ my @needed;
+
+ foreach my $pkg_name (@pkg_names) {
+ my ($time, at res) = split / /, ($cache{$pkg_name} || '');
+ if (defined $time and $time =~ /^\d+$/ and $time + 24 * 60 * 60 * 7 > time) {
+ $async_log->debug("using cached info for $pkg_name");
+ }
+ else {
+ push @needed, $pkg_name;
+ $necessary++;
+ }
+ }
+
+ if (not $necessary) {
+ $callback->();
+ return;
+ }
+
+ my $url = "http://qa.debian.org/cgi-bin/madison.cgi?package=".join('+', at needed)."&text=on" ;
+ say "Connecting to qa.debian.org to check ", scalar @needed, " package versions. Please wait..." ;
+
+ my $request;
+ $request = http_request(
+ GET => $url,
+ timeout => 20, # seconds
+ sub {
+ my ($body, $hdr) = @_;
+ $async_log->debug("callback of get_available_version called on @needed");
+ if ($hdr->{Status} =~ /^2/) {
+ 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';
+ }
+ say "got info for $necessary packages: ", join(' ',sort keys %res) ;
+ foreach my $pname (keys %res) {
+ $cache{$pname} = time ." ".join(' ',@{$res{$pname}}) ;
+ }
+ $callback->();
+ }
+ else {
+ say "Error for $url: ($hdr->{Status}) $hdr->{Reason}";
+ }
+ undef $request;
+ }
+ );
+}
+
__PACKAGE__->meta->make_immutable;
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