r11497 - /scripts/qa/DebianQA/Watch.pm

[tincho-guest at users.alioth.debian.org]

Author: tincho-guest
Date: Sun Dec 23 10:14:17 2007
New Revision: 11497

URL: http://svn.debian.org/wsvn/?sc=1&rev=11497
Log:
Restored part of the old code (now adapted to use find-ls.gz) to cope correctly
with modules/author watchfile matches.

Modified:
    scripts/qa/DebianQA/Watch.pm

Modified: scripts/qa/DebianQA/Watch.pm
URL: http://svn.debian.org/wsvn/scripts/qa/DebianQA/Watch.pm?rev=11497&op=diff
==============================================================================
--- scripts/qa/DebianQA/Watch.pm (original)
+++ scripts/qa/DebianQA/Watch.pm Sun Dec 23 10:14:17 2007
@@ -37,7 +37,8 @@
     debug("watch_download($force, (@pkglist))");
 
     if($CFG{watch}{use_cpan}) {
-        cpan_download($force);
+        cpan_dist_download($force);
+        cpan_index_download($force);
     }
     my $complete;
     if(not @pkglist) {
@@ -264,7 +265,6 @@
     return(undef, @vers);
 }
 
-
 sub cpan_lookup($$) {
     my($dir, $filter) = @_;
 
@@ -275,10 +275,13 @@
     my $origdir = $dir;
 
     $type =~ s/.*(dist|modules|authors).*/$1/ or return ();
+    my $cpan;
     if($type eq "dist") {
         $filter =~ s/.*\///;
-    }
-    my $cpan = cpan_download()->{$type};
+        $cpan = cpan_dist_download();
+    } else {
+        $cpan = cpan_index_download()->{$type};
+    }
     $dir =~ s/$cpanregex//i;
     $dir =~ s{^/+}{};
     debug("Looking for $dir + $filter into CPAN $type cache");
@@ -290,40 +293,42 @@
     foreach(keys %{$cpan->{$dir}}) {
         next unless ($_ =~ $filter);
         my $filt_ver = $1;
-        my $cpan_ver = $cpan->{$dir}{$_}{version};
-        if($filt_ver ne $cpan_ver) {
-            # Try to remove initial "v"s, if any
-            $filt_ver =~ s/^v//;
-            $cpan_ver =~ s/^v//;
-        }
-        if($filt_ver ne $cpan_ver) {
-            warn("Version mismatch: uscan says $filt_ver, cpan says $cpan_ver");
-            return ("VersionMismatch");
+        if($type eq "dist") {
+            my $cpan_ver = $cpan->{$dir}{$_}{version};
+            if($filt_ver ne $cpan_ver) {
+                # Try to remove initial "v"s, if any
+                $cpan_ver =~ s/^v//;
+            }
+            if($filt_ver ne $cpan_ver) {
+                warn("Version mismatch: uscan says $filt_ver, ",
+                    "cpan says $cpan_ver");
+                return ("VersionMismatch");
+            }
         }
         push @res, {
-            upstream_version => $cpan_ver,
+            upstream_version => $filt_ver,
             upstream_url => (
                 $type eq "dist" ?
-                "$base/CPAN/authors/id/" . $cpan->{$dir}{$_}{author_path} :
-                $origdir
-            ) . "/$_"
+                "$base/CPAN/authors/id/" . $cpan->{$dir}{$_}{path} :
+                "$origdir/$_"
+            )
         };
     }
     # Allow this to gracefully degrade to a normal uscan check
     #return ("NotFound") unless(@res);
     return (undef, @res);
 }
-sub cpan_download(;$) {
+sub cpan_dist_download(;$) {
     my $force = shift;
     unless($force) {
-        my $cpan = read_cache("cpan", "", 0);
+        my $cpan = read_cache("cpan_dists", "", 0);
         if($CFG{watch}{cpan_ttl} * 60 > time - find_stamp($cpan, "")) {
             return $cpan;
         }
     }
 
     my $url = $CFG{watch}{cpan_mirror} . "/modules/02packages.details.txt.gz";
-    info("Rebuilding CPAN cache from $url");
+    info("Rebuilding CPAN dists cache from $url");
     open(TMP, "+>", undef) or die $!;
     my $res = $ua->get($url, ":content_cb" => sub {
             print TMP $_[0] or die $!;
@@ -368,21 +373,62 @@
         my $version = $distinfo->version();
         my $filename = $distinfo->filename();
 
-        my $author_path = $1 if($tarball =~ m#(.*)/#);
-        (my $module_path = $distname) =~ s#-.*##g;
-
-        $cpan->{modules}{$module_path}{$filename} = 
-        $cpan->{authors}{$author_path}{$filename} =
-        $cpan->{dist}{$distname}{$filename} = {
-            author_path => $author_path,
-            module_path => $module_path,
-            filename => $filename,
-            distname => $distname,
+        $cpan->{$distname}{$filename} = {
+            path => $tarball,
             version => $version
         };
     }
     close $data;
-    update_cache("cpan", $cpan, "", 1);
+    update_cache("cpan_dists", $cpan, "", 1);
     return $cpan;
 }
+sub cpan_index_download(;$) {
+    my $force = shift;
+    unless($force) {
+        my $cpan = read_cache("cpan_index", "", 0);
+        if($CFG{watch}{cpan_ttl} * 60 > time - find_stamp($cpan, "")) {
+            return $cpan;
+        }
+    }
+
+    my $url = $CFG{watch}{cpan_mirror} . "/indices/find-ls.gz";
+    info("Rebuilding CPAN indices cache from $url");
+    open(TMP, "+>", undef) or die $!;
+    my $res = $ua->get($url, ":content_cb" => sub {
+            print TMP $_[0] or die $!;
+        });
+    unless($res->is_success()) {
+        warn "Can't download $url: " . $res->message();
+        return 0;
+    }
+    seek(TMP, 0, SEEK_SET) or die "Can't seek: $!\n";
+    my $gz = Compress::Zlib::gzopen(\*TMP, "rb")
+        or die "Can't open compressed file: $!\n";
+
+    my $data;
+    open($data, "+>", undef) or die $!;
+    my $buffer = " " x 4096;
+    my $bytes;
+    while(($bytes = $gz->gzread($buffer)) > 0) {
+        print $data $buffer;
+    }
+    die $gz->gzerror if($bytes < 0);
+    close TMP;
+    #my $z = new IO::Uncompress::Gunzip(\$data);
+
+    seek($data, 0, SEEK_SET) or die "Can't seek: $!\n";
+
+    my($dir, $type);
+    my $cpan = {};
+    while(<$data>) {
+        chomp;
+        my $file = (split)[8];
+        $file =~ m{^(authors|modules)/(?:id|by-module)/(.*)/(.*\.(?:bz2|gz|zip|pl|pm|tar|tgz))$}i or next;
+        my($type, $dir, $tarball) = ($1, $2, $3);
+        $cpan->{$type}{$dir}{$tarball} = 1;
+    }
+    close $data;
+    update_cache("cpan_index", $cpan, "", 1);
+    return $cpan;
+}
 1;