r8888 - in /scripts/qa: DebianQA.conf-sample DebianQA/Archive.pm DebianQA/Config.pm DebianQA/Watch.pm fetchdata
tincho-guest at users.alioth.debian.org
tincho-guest at users.alioth.debian.org
Tue Nov 6 06:16:38 UTC 2007
Author: tincho-guest
Date: Tue Nov 6 06:16:38 2007
New Revision: 8888
URL: http://svn.debian.org/wsvn/?sc=1&rev=8888
Log:
CPAN cache added (only by-dist is missing)
Modified:
scripts/qa/DebianQA.conf-sample
scripts/qa/DebianQA/Archive.pm
scripts/qa/DebianQA/Config.pm
scripts/qa/DebianQA/Watch.pm
scripts/qa/fetchdata
Modified: scripts/qa/DebianQA.conf-sample
URL: http://svn.debian.org/wsvn/scripts/qa/DebianQA.conf-sample?rev=8888&op=diff
==============================================================================
--- scripts/qa/DebianQA.conf-sample (original)
+++ scripts/qa/DebianQA.conf-sample Tue Nov 6 06:16:38 2007
@@ -19,8 +19,10 @@
incoming_ttl = 60
[watch] # Not implemented yet
+ttl = 360 # 6 hours
use_cpan = 1
-cpan_mirror = ftp://cpan.org/pub/CPAN
+cpan_mirror = ftp://cpan.org/ls-lR.gz
+cpan_ttl = 360 # 6 hours
[bts]
ttl = 360 # 6 hours
Modified: scripts/qa/DebianQA/Archive.pm
URL: http://svn.debian.org/wsvn/scripts/qa/DebianQA/Archive.pm?rev=8888&op=diff
==============================================================================
--- scripts/qa/DebianQA/Archive.pm (original)
+++ scripts/qa/DebianQA/Archive.pm Tue Nov 6 06:16:38 2007
@@ -137,6 +137,7 @@
/^version:\s*(\S+)\s*$/mi or next;
$vers{$pkg} = $1;
}
+ close $data;
}
return \%vers;
}
Modified: scripts/qa/DebianQA/Config.pm
URL: http://svn.debian.org/wsvn/scripts/qa/DebianQA/Config.pm?rev=8888&op=diff
==============================================================================
--- scripts/qa/DebianQA/Config.pm (original)
+++ scripts/qa/DebianQA/Config.pm Tue Nov 6 06:16:38 2007
@@ -34,8 +34,10 @@
incoming_ttl => 60,
},
watch => { # Not implemented yet
+ ttl => 360,
use_cpan => 1,
- cpan_mirror => "ftp://cpan.org/pub/CPAN",
+ cpan_mirror => "ftp://cpan.org/ls-lR.gz",
+ cpan_ttl => 360 # 6 hours
},
bts => {
ttl => 360, # 6 hours
Modified: scripts/qa/DebianQA/Watch.pm
URL: http://svn.debian.org/wsvn/scripts/qa/DebianQA/Watch.pm?rev=8888&op=diff
==============================================================================
--- scripts/qa/DebianQA/Watch.pm (original)
+++ scripts/qa/DebianQA/Watch.pm Tue Nov 6 06:16:38 2007
@@ -22,7 +22,8 @@
use DebianQA::DebVersions;;
use LWP::UserAgent;
-my $ttl = 6;
+my $cpanregex =
+qr#^(?:http|ftp)://\S*cpan\S*/(modules/by-module|(?:by-)?authors/id)\b#;
my $ua = new LWP::UserAgent;
$ua->timeout(10);
@@ -61,11 +62,13 @@
foreach my $wline (@wlines) {
my $md5 = $wline->{md5};
next unless($md5);
- if(not $force and $cdata->{$md5}
- and $ttl * 60 > time - find_stamp($cdata, $md5)) {
+ if(not $force and $cdata->{$md5} and
+ $CFG{watch}{ttl} * 60 > time - find_stamp($cdata, $md5)) {
$watch{$md5} = $cdata->{$md5};
} else {
my ($watcherr, $ups_ver, $ups_mangled) = uscan($wline);
+ warn("Error while processing $pkg watch file: $watcherr") if(
+ $watcherr);
$watch{$md5} = {
watch_error => $watcherr,
upstream_version => $ups_ver,
@@ -121,8 +124,6 @@
warn("Invalid watch line: $wline");
return("Invalid");
}
- my $url = $1;
- $url =~ s{^http://sf.net/}{http://sf.net.projects/};
$wline =~ s{^http://sf\.net/(\S+)}{http://qa.debian.org/watch/sf.php/$1};
my @items = split(/\s+/, $wline);
@@ -142,36 +143,105 @@
return("Invalid");
}
debug("uscan $dir $filter");
- $url ||= $dir; # FIXME: NO-OP
- debug("Downloading $dir");
- my $res = $ua->get($dir);
- unless($res->is_success) {
- error("Unable to get $dir: " . $res->message());
- return ("Network");
- }
- my $page = $res->decoded_content();
my @vers;
- if($dir =~ /^http/) {
- while($page =~ /<a [^>]*href="([^"]+)"[^>]*>/ig ) {
- my $href = $1;
- push @vers, [$1, $1] if $href =~ $filter;
- }
- } else {
- while($page =~ /(?:^|\s+)$filter(?:\s+|$)/ig) {
- push @vers, [$1, $1];
- }
- }
+ unless($CFG{watch}{use_cpan} and $dir =~ $cpanregex
+ and @vers = cpan_lookup($dir, $filter)) {
+ debug("Downloading $dir");
+ my $res = $ua->get($dir);
+ unless($res->is_success) {
+ error("Unable to get $dir: " . $res->message());
+ return ("Network");
+ }
+ my $page = $res->decoded_content();
+ if($dir =~ /^http/) {
+ while($page =~ /<a [^>]*href="([^"]+)"[^>]*>/ig ) {
+ push @vers, $1 if $1 =~ $filter;
+ }
+ } else {
+ push @vers, ($page =~ /(?:^|\s+)$filter(?:\s+|$)/ig);
+ }
+ }
+ my @mangled;
foreach my $uver (@vers) {
+ push @mangled, $uver;
next unless($watch{opts}{uversionmangle});
foreach(split(/;/, @{$watch{opts}{uversionmangle}})) {
- eval "\$uver->[1] =~ $_";
+ eval "\$mangled[-1] =~ $_";
if($@) {
error("Invalid watchfile: $@");
return "Invalid";
}
}
}
- @vers = sort({ deb_compare($a->[1], $b->[1]) } @vers);
- return(undef, @{$vers[-1]});
+ my @order = sort({ deb_compare($mangled[$a], $mangled[$b]) } (0..$#vers))
+ or return("Invalid");
+ return(undef, $vers[$order[-1]], $mangled[$order[-1]]);
+}
+sub cpan_lookup($$) {
+ my($dir, $filter) = @_;
+
+ return undef unless($dir =~ $cpanregex);
+ my $base = $1;
+ unless($base =~ s/.*(modules|authors).*//) {
+ return undef;
+ }
+ $base = $1;
+ my $cpan = cpan_download($base);
+ my $olddir = $dir;
+ $dir =~ s/$cpanregex//;
+ $dir =~ s{/+$}{};
+ $dir =~ s{^/+}{};
+ debug("Looking for $dir + $filter into CPAN $base cache");
+ return undef unless(exists($cpan->{$dir}));
+ return grep(defined, map({ $_ =~ $filter ? $1 : undef } @{$cpan->{$dir}}));
+}
+sub cpan_download($) {
+ my $base = shift;
+ my $cpan = read_cache("cpan", "", 0);
+ if($CFG{watch}{cpan_ttl} * 60 > time - find_stamp($cpan, $base)) {
+ return $cpan->{$base};
+ }
+ $cpan = {};
+
+ my $url = $CFG{watch}{cpan_mirror};
+ info("Rebuilding CPAN cache from $url");
+ my $res = $ua->get($url);
+ unless($res->is_success()) {
+ warn "Can't download $url: " . $res->message();
+ return undef;
+ }
+ my $gzdata = $res->content();
+ #my $z = new IO::Uncompress::Gunzip(\$data);
+ my $uncdata = Compress::Zlib::memGunzip(\$gzdata);
+ my $data = IO::Scalar->new(\$uncdata);
+
+ my($dir, $type);
+ while(<$data>) {
+ chomp;
+ if(/^(.+):$/) {
+ $dir = $1;
+ if($dir =~ m{/.*(?:authors/id|modules/by-module)/+(.*?)/*$}) {
+ my $subdir = $1;
+ $dir =~ /(authors|modules)/;
+ $type = $1;
+ $dir = $subdir;
+ #$cpan->{$type} ||= {};
+ #$cpan->{$type}{$dir} ||= [];
+ } else {
+ $type = undef;
+ }
+ next;
+ }
+ next unless($type
+ and /^[-l]r.....r.*\.(?:bz2|gz|rar|zip|pl|pm|tar|tgz)$/i);
+ s/ -> .*//;
+ my @fields = split;
+ if(@fields >= 9 and $fields[8] ne "CHECKSUMS") {
+ push @{$cpan->{$type}{$dir}}, $fields[8];
+ }
+ }
+ close $data;
+ update_cache("cpan", $cpan, "", 1);
+ return $cpan->{$base};
}
1;
Modified: scripts/qa/fetchdata
URL: http://svn.debian.org/wsvn/scripts/qa/fetchdata?rev=8888&op=diff
==============================================================================
--- scripts/qa/fetchdata (original)
+++ scripts/qa/fetchdata Tue Nov 6 06:16:38 2007
@@ -38,7 +38,7 @@
}
}
# We need this first
-svn_download($opts->{force}, $svn_rev, @dirs);
+#svn_download($opts->{force}, $svn_rev, @dirs);
if($parallel) {
local $SIG{CHLD} = "IGNORE";
my @pids;
More information about the Pkg-perl-cvs-commits
mailing list