[libconfig-model-dpkg-perl] 02/03: Dpkg::Dependency: added global function cache_info_from_madison

[dod at debian.org]

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