[libconfig-model-dpkg-perl] 03/03: Backend Dpkg Control: query info for all package in one call. (Closes: #735000)

[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 210498051f4810c19f1b51c2756562f3b1a0b9cb
Author: Dominique Dumont <dod at debian.org>
Date:   Thu Jan 30 19:47:12 2014 +0100

    Backend Dpkg Control: query info for all package in one call. (Closes: #735000)
---
 lib/Config/Model/Backend/Dpkg/Control.pm | 54 ++++++++++++++++++++++++++------
 1 file changed, 45 insertions(+), 9 deletions(-)

diff --git a/lib/Config/Model/Backend/Dpkg/Control.pm b/lib/Config/Model/Backend/Dpkg/Control.pm
index ba855c8..c57cbd5 100644
--- a/lib/Config/Model/Backend/Dpkg/Control.pm
+++ b/lib/Config/Model/Backend/Dpkg/Control.pm
@@ -1,6 +1,6 @@
 
 package Config::Model::Backend::Dpkg::Control ;
-
+use 5.10.1;
 use Mouse ;
 
 extends 'Config::Model::Backend::Any';
@@ -12,8 +12,12 @@ use Config::Model::Exception ;
 use File::Path;
 use Log::Log4perl qw(get_logger :levels);
 use AnyEvent ;
+use AnyEvent::HTTP ;
+
+use Config::Model::Dpkg::Dependency;
 
 my $logger = get_logger("Backend::Dpkg::Control") ;
+my $async_log = get_logger("Async::Value::Dependency") ;
 
 sub suffix { return '' ; }
 
@@ -35,7 +39,12 @@ sub read {
     $logger->info("Parsing $args{file_path}");
     # load dpkgctrl file
     my $c = $self -> parse_dpkg_file ($args{io_handle}, $args{check}, 1 ) ;
-    
+
+    # hack to fix Debian #735000: ask for infos for all packages not in cache in one go. Thus
+    # the async code in Dependency is less likely to break since the cache is already up-to-date
+    # when dependencies are checked one by one
+    $self->fill_package_cache ($c);
+
     my $root = $args{object} ;
     my $check = $args{check} ;
     my $file;
@@ -48,8 +57,7 @@ sub read {
 
     $logger->debug("Reading binary package names");
     # we assume that package name is the first item in the section data
-    
-    
+
     while (@$c ) {
         my ($section_line,$section) = splice @$c,0,2 ;
         my $package_name;
@@ -69,14 +77,42 @@ sub read {
         $node = $root->grab("binary:$package_name") ;
         $self->read_sections ($node, $section_line, $section, $args{check});
     }
-
-    
     return 1 ;
 }
 
-#
-# New subroutine "read_section" extracted - Tue Sep 28 17:19:44 2010.
-#
+sub fill_package_cache {
+    my $self = shift;
+    my $c = shift;
+
+    # scan data to find package name and query madison for info for all packages in a single call
+    my %packages; # use a hash to elliminate duplicates
+    foreach my $s (@$c) {
+        next unless ref $s eq 'ARRAY' ;
+        my %section = @$s ; # don't care about order
+        foreach my $found (keys %section) {
+            if ($found =~ /Depends|Suggests|Recommends|Enhances|Breaks|Conflicts|Replaces/) {
+                my $v = $section{$found}[0] ; # $section{found} array is [ value, line_nb, altered_value , comment ]
+                my @v = grep { not /\$/ } map { s/\[.*\]//g; s/\(.*\)//; s/\s//g; $_;} split /[\s\n]*[,|][\s\n]*/, $v;
+                chomp @v;
+                map {$packages{$_} =1 ;} @v;
+            }
+        }
+    }
+
+    my $cv = AnyEvent->condvar ;
+
+    $async_log->debug("start call to madison") ;
+
+    my $cb = sub {
+        $async_log->debug("call to madison done") ;
+        $cv->send;
+    } ;
+
+    my @pkgs = keys %packages;
+    Config::Model::Dpkg::Dependency::cache_info_from_madison ($cb, @pkgs);
+    $cv->recv;
+}
+
 sub read_sections {
     my $self = shift ;
     my $node = shift;

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libconfig-model-dpkg-perl.git