r11497 - /scripts/qa/DebianQA/Watch.pm
tincho-guest at users.alioth.debian.org
tincho-guest at users.alioth.debian.org
Sun Dec 23 10:14:18 UTC 2007
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;
More information about the Pkg-perl-cvs-commits
mailing list