r9009 - in /scripts/qa: DebianQA/Svn.pm DebianQA/Watch.pm qareport qareport.cgi templates/by_category
tincho-guest at users.alioth.debian.org
tincho-guest at users.alioth.debian.org
Thu Nov 8 07:22:23 UTC 2007
Author: tincho-guest
Date: Thu Nov 8 07:22:23 2007
New Revision: 9009
URL: http://svn.debian.org/wsvn/?sc=1&rev=9009
Log:
- Svn: Rename of mangled_ver to unmangled_ver for consistency
- Big change in Watch, now saves upstream url, correctly process directories
with embbeded () and general joy.
Modified:
scripts/qa/DebianQA/Svn.pm
scripts/qa/DebianQA/Watch.pm
scripts/qa/qareport
scripts/qa/qareport.cgi
scripts/qa/templates/by_category
Modified: scripts/qa/DebianQA/Svn.pm
URL: http://svn.debian.org/wsvn/scripts/qa/DebianQA/Svn.pm?rev=9009&op=diff
==============================================================================
--- scripts/qa/DebianQA/Svn.pm (original)
+++ scripts/qa/DebianQA/Svn.pm Thu Nov 8 07:22:23 2007
@@ -153,7 +153,7 @@
}
my @versions = sort({ deb_compare($a, $b) }
grep(defined, map({ $_->{unmangled_ver} } @$watch)));
- $svn{$dir}{mangled_ver} = $versions[-1];
+ $svn{$dir}{unmangled_ver} = $versions[-1];
$svn{$dir}{watch} = $watch;
}
# Retain lock
@@ -264,7 +264,7 @@
}
}
}
- debug("Mangled version: $unmangled");
+ debug("Unmangled version: $unmangled");
push @wspecs, {
line => $_,
unmangled_ver => $unmangled,
Modified: scripts/qa/DebianQA/Watch.pm
URL: http://svn.debian.org/wsvn/scripts/qa/DebianQA/Watch.pm?rev=9009&op=diff
==============================================================================
--- scripts/qa/DebianQA/Watch.pm (original)
+++ scripts/qa/DebianQA/Watch.pm Thu Nov 8 07:22:23 2007
@@ -41,12 +41,11 @@
my $complete;
if(not @pkglist) {
$complete = 1;
- @pkglist = get_pkglist();
+ @pkglist = grep(! /^\//, get_pkglist());
}
my $cdata = watch_get() unless($force);
my(%watch, %watch2);
foreach my $pkg (@pkglist) {
- next if($pkg =~ /^\//);
debug("Retrieving svn info for $pkg");
my $svndata = svn_get(pkgname2svndir($pkg));
if($svndata->{watch_error}) {
@@ -71,55 +70,46 @@
$CFG{watch}{ttl} * 60 > time - find_stamp($cdata, $md5)) {
$watch{$md5} = $cdata->{$md5};
} else {
- my ($watcherr, $ups_ver, $ups_mangled) = uscan($wline);
+ my ($watcherr, %uscand) = uscan($wline->{line},
+ %{$wline->{opts}});
if($watcherr) {
warn("Error while processing $pkg watch file: $watcherr");
} else {
- debug("Found: version $ups_ver (mangled: $ups_mangled)");
+ info("Found: version $uscand{upstream_version} ",
+ "from $uscand{upstream_url} ",
+ "(unmangled: $uscand{upstream_unmangled})");
}
- $watch{$md5} = {
- watch_error => $watcherr,
- upstream_version => $ups_ver,
- upstream_mangled => $ups_mangled
- };
+ $watch{$md5} = { watch_error => $watcherr, %uscand };
}
my $diff;
- if($watch{$md5}{upstream_mangled}) {
+ if($watch{$md5}{upstream_unmangled}) {
$diff = deb_compare($wline->{unmangled_ver},
- $watch{$md5}{upstream_mangled});
+ $watch{$md5}{upstream_unmangled});
$watch{$md5}{watch_error} = "InvalidVersion" unless(
defined $diff);
} else {
$watch{$md5}{watch_error} ||= "Error";
}
- push @wresult, [ $diff, @{$watch{$md5}}{
- qw/watch_error upstream_version upstream_mangled/ } ];
- }
- my @noerror = sort({ deb_compare($a->[3], $b->[3]) }
- grep({ not $_->[1] } @wresult));
+ push @wresult, { diff => $diff, %{$watch{$md5}} };
+ }
+ my @noerror = grep({ not $_->{watch_error} } @wresult);
+ @noerror = sort({
+ deb_compare($a->{upstream_unmangled}, $b->{upstream_unmangled})
+ } @noerror);
unless(@noerror) {
- $watch2{$pkg} = { error => $wresult[0][1] };
+ $watch2{$pkg} = { error => $wresult[0]{watch_error} };
next;
}
my @result;
- if(@result = grep({ $_->[0] < 0 } @noerror)) {
- $watch2{$pkg} = {
- info => "NeedsUpgrade",
- upstream_ver => $result[-1][2],
- upstream_mangled => $result[-1][3]
- };
- } elsif(@result = grep( { not $_->[0] } @noerror)) {
- $watch2{$pkg} = {
- upstream_ver => $result[0][2],
- upstream_mangled => $result[0][3]
- }; # OK
+ if(@result = grep({ $_->{diff} < 0 } @noerror)) {
+ $watch2{$pkg} = $result[-1];
+ } elsif(@result = grep( { not $_->{diff} } @noerror)) {
+ $watch2{$pkg} = $result[0];
} else {
- $watch2{$pkg} = {
- info => "NewerThanUpstream",
- upstream_ver => $noerror[0][2],
- upstream_mangled => $noerror[0][3]
- };
- }
+ $watch2{$pkg} = $noerror[0];
+ }
+ delete($watch2{$pkg}{diff}) unless($watch2{$pkg}{diff});
+ delete($watch2{$pkg}{watch_error}) unless($watch2{$pkg}{watch_error});
}
update_cache("watch", \%watch, "", $complete, 1);
update_cache("consolidated", \%watch2, "watch", $complete, 0);
@@ -136,16 +126,14 @@
return read_cache("consolidated", "watch/$path", 0);
}
sub uscan($) {
- my %watch = %{$_[0]};
- my $wline = $watch{line};
+ my($wline, %opts) = @_;
info("Processing watch line $wline");
- unless($wline =~ m{^((?:https?|ftp)://\S+)/}) {
+ $wline =~ s{^http://sf\.net/(\S+)}{http://qa.debian.org/watch/sf.php/$1};
+ unless($wline =~ m{^(?:(?:https?|ftp)://\S+?)/}) {
warn("Invalid watch line: $wline");
return("Invalid");
}
-
- $wline =~ s{^http://sf\.net/(\S+)}{http://qa.debian.org/watch/sf.php/$1};
my @items = split(/\s+/, $wline);
my($dir, $filter);
@@ -169,28 +157,17 @@
warn("CPAN lookup failed for $dir + $filter") unless(@vers);
}
unless(@vers) {
- debug("Downloading $dir");
- my $res = $ua->get($dir);
- unless($res->is_success) {
- error("Unable to get $dir: " . $res->message());
- return ("NotFound") if($res->code == 404);
- return ("DownloadError");
- }
- 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);
- }
- }
+ @vers = recurse_dirs($filter, $dir, "");
+ my $status = shift @vers;
+ return $status || "NotFound" unless(@vers);
+ }
+
my @mangled;
foreach my $uver (@vers) {
- push @mangled, $uver;
- next unless($watch{opts}{uversionmangle});
- debug("Mangle option: ", join(", ", @{$watch{opts}{uversionmangle}}));
- foreach(split(/;/, join(";", @{$watch{opts}{uversionmangle}}))) {
+ push @mangled, $uver->{upstream_version};
+ next unless($opts{uversionmangle});
+ debug("Mangle option: ", join(", ", @{$opts{uversionmangle}}));
+ foreach(split(/;/, join(";", @{$opts{uversionmangle}}))) {
debug("Executing '\$mangled[-1] =~ $_'");
eval "\$mangled[-1] =~ $_";
if($@) {
@@ -198,12 +175,82 @@
return("Invalid");
}
}
- debug("Mangled version: $mangled[-1]");
- }
- return("Invalid") unless(@vers);
+ debug("Unmangled version: $mangled[-1]");
+ }
my @order = sort({ deb_compare($mangled[$a], $mangled[$b]) } (0..$#vers));
- return(undef, $vers[$order[-1]], $mangled[$order[-1]]);
-}
+ return(undef,
+ %{$vers[$order[-1]]},
+ upstream_unmangled => $mangled[$order[-1]]);
+}
+sub recurse_dirs($$$);
+sub recurse_dirs($$$) {
+ my($filter, $base, $remaining) = @_;
+ debug("recurse_dirs($filter, $base, $remaining)");
+
+ my @rparts = split(/\/+/, $remaining) if($remaining);
+ while(@rparts and $rparts[0] !~ /\(/) {
+ $base .= "/" . shift @rparts;
+ }
+ if(@rparts) {
+ my ($status, @data) = recurse_dirs($rparts[0], $base, "");
+ return $status unless(@data);
+ @data = sort({
+ deb_compare($a->{upstream_version}, $b->{upstream_version})
+ } @data);
+ $base = $data[-1]{upstream_url};
+ }
+ unless($base =~ m{(^\w+://[^/]+)(/.*?)/*$}) {
+ error("Invalid base: $base");
+ return("Invalid");
+ }
+ my $site = $1;
+ my $path = $2;
+ my $pattern;
+ if($filter =~ m{^/}) {
+ $pattern = qr{(?:^$site)?$filter};
+ } elsif($filter !~ m{^\w+://}) {
+ $pattern = qr{(?:(?:^$site)?$path/)?$filter};
+ } else {
+ $pattern = $filter;
+ }
+
+ debug("Downloading $base");
+ my $res = $ua->get($base);
+ unless($res->is_success) {
+ error("Unable to get $base: " . $res->message());
+ return ("NotFound") if($res->code == 404);
+ return ("DownloadError");
+ }
+ my $page = $res->decoded_content();
+ $page =~ s/<!--.*?-->//gs;
+ $page =~ s/\n+/ /gs;
+
+ my @candidates;
+ if($base =~ /^ftp/) {
+ @candidates = split(/\s+/, $page);
+ } else {
+ @candidates = grep(defined,
+ ($page =~ m{<a\s[^>]*href\s*=\s*(?:"([^"]+)"|([^"]\S+))}gi));
+ }
+ my @vers;
+ foreach my $url (grep(m{^$pattern$}, @candidates)) {
+ $url =~ m{^$pattern$};
+ my @ver = map({substr($url, $-[$_], $+[$_] - $-[$_])} (1..$#+));
+ if($url =~ m{^/}) {
+ $url = $site . $url;
+ } elsif($url !~ m{^\w+://}) {
+ $url = $site . $path . "/" . $url;
+ }
+ push @vers, {
+ upstream_version => join(".", @ver),
+ upstream_url => $url };
+ }
+ debug("Versions found: ", join(", ", map({ $_->{upstream_version} }
+ @vers)));
+ return(undef, @vers);
+}
+
+
sub cpan_lookup($$) {
my($dir, $filter) = @_;
@@ -216,12 +263,18 @@
}
my $cpan = cpan_download()->{$base};
my $olddir = $dir;
+ $olddir =~ s{/+$}{};
$dir =~ s/$cpanregex//i;
$dir =~ s{/+$}{};
$dir =~ s{^/+}{};
debug("Looking for $dir + $filter into CPAN $base cache");
return () unless(exists($cpan->{$dir}));
- return grep(defined, map({ $_ =~ $filter ? $1 : undef } @{$cpan->{$dir}}));
+ return map({
+ $_ =~ $filter ? {
+ upstream_version => $1,
+ upstream_url => $olddir . ($base eq "dist" ? "" : "/$_")
+ } : ()
+ } @{$cpan->{$dir}});
}
sub cpan_download(;$) {
my $force = shift;
Modified: scripts/qa/qareport
URL: http://svn.debian.org/wsvn/scripts/qa/qareport?rev=9009&op=diff
==============================================================================
--- scripts/qa/qareport (original)
+++ scripts/qa/qareport Thu Nov 8 07:22:23 2007
@@ -43,12 +43,13 @@
my $werr = $data->{watch}{$pkg}{error};
my $dver = $data->{svn}{$pkg}{version} || 0;
my $dwerr = $data->{svn}{$pkg}{watch_error};
- my $m_dver = $data->{svn}{$pkg}{mangled_ver} || 0;
+ my $m_dver = $data->{svn}{$pkg}{unmangled_ver} || 0;
my $undver = $data->{svn}{$pkg}{un_version};
my $archver = $data->{archive}{$pkg}{most_recent} || 0;
my $archsuit = $data->{archive}{$pkg}{most_recent_src} || 0;
- my $uver = $data->{watch}{$pkg}{upstream_ver};
- my $m_uver = $data->{watch}{$pkg}{upstream_mangled};
+ my $uver = $data->{watch}{$pkg}{upstream_version};
+ my $u_uver = $data->{watch}{$pkg}{upstream_unmangled};
+ my $uurl = $data->{watch}{$pkg}{upstream_url};
my @bugs = map({ "#$_" } keys %{$data->{bts}{$pkg}});
my $status;
@@ -60,11 +61,11 @@
$status = "Ancient version in SVN";
} elsif(deb_compare($archver, $dver) != 0) {
$status = "Needs uploading";
- } elsif($dwerr or not $m_dver or not $m_uver or not $uver) {
+ } elsif($dwerr or not $m_dver or not $u_uver or not $uver) {
$status = "Watchfile problem";
- } elsif(deb_compare($m_dver, $m_uver) > 0) {
+ } elsif(deb_compare($m_dver, $u_uver) > 0) {
$status = "Ancient version in upstream?";
- } elsif(deb_compare($m_dver, $m_uver) != 0) {
+ } elsif(deb_compare($m_dver, $u_uver) != 0) {
$status = "Needs upgrading to newer upstream";
} elsif($werr) {
$status = "Watchfile problem";
@@ -80,7 +81,7 @@
print " Archive: ", $archver || "Not uploaded";
print " ($archsuit)" if($archsuit);
print " Upstream: ", $uver || "Unknown";
- print " (mangled: ", $m_uver || "Unknown", ")\n";
+ print " (mangled: ", $u_uver || "Unknown", ")\n";
}
print " + Bugs: ", join(", ", @bugs), "\n" if(@bugs);
}
Modified: scripts/qa/qareport.cgi
URL: http://svn.debian.org/wsvn/scripts/qa/qareport.cgi?rev=9009&op=diff
==============================================================================
--- scripts/qa/qareport.cgi (original)
+++ scripts/qa/qareport.cgi Thu Nov 8 07:22:23 2007
@@ -50,12 +50,13 @@
my $werr = $data->{watch}{$pkg}{error};
my $dver = $data->{svn}{$pkg}{version} || 0;
my $dwerr = $data->{svn}{$pkg}{watch_error};
- my $m_dver = $data->{svn}{$pkg}{mangled_ver} || 0;
+ my $m_dver = $data->{svn}{$pkg}{unmangled_ver} || 0;
my $undver = $data->{svn}{$pkg}{un_version};
my $archver = $data->{archive}{$pkg}{most_recent} || 0;
my $archsuit = $data->{archive}{$pkg}{most_recent_src} || 0;
- my $uver = $data->{watch}{$pkg}{upstream_ver};
- my $m_uver = $data->{watch}{$pkg}{upstream_mangled};
+ my $uver = $data->{watch}{$pkg}{upstream_version};
+ my $u_uver = $data->{watch}{$pkg}{upstream_unmangled};
+ my $uurl = $data->{watch}{$pkg}{upstream_url};
my @bugs = sort keys %{$data->{bts}{$pkg}};
my $note;
@@ -72,13 +73,13 @@
push @for_upload, $pkg;
} elsif($werr and $werr eq "Native") {
$note = "Native package";
- } elsif($dwerr or not $m_dver or not $m_uver or not $uver) {
+ } elsif($dwerr or not $m_dver or not $u_uver or not $uver) {
$note = "Watchfile problem";
push @wip, $pkg;
- } elsif(deb_compare($m_dver, $m_uver) > 0) {
+ } elsif(deb_compare($m_dver, $u_uver) > 0) {
$note = "Ancient version in upstream?";
push @weird, $pkg;
- } elsif(deb_compare($m_dver, $m_uver) != 0) {
+ } elsif(deb_compare($m_dver, $u_uver) != 0) {
$note = "Needs upgrading to newer upstream";
push @for_upgrade, $pkg;
} elsif($werr) {
Modified: scripts/qa/templates/by_category
URL: http://svn.debian.org/wsvn/scripts/qa/templates/by_category?rev=9009&op=diff
==============================================================================
--- scripts/qa/templates/by_category (original)
+++ scripts/qa/templates/by_category Thu Nov 8 07:22:23 2007
@@ -48,7 +48,10 @@
>)</span>[% END #IF %]</a></td>
<td>[% IF arch_ver %]<a href="http://packages.qa.debian.org/$pkg">$arch_ver</a>[% END #IF %]</td>
<td>[% INCLUDE bts_link data=data pkg=pkg %]</td>
- <td>${data.watch.$pkg.upstream_mangled || data.watch.$pkg.error}</td>
+ <td>[% IF data.watch.$pkg.upstream_unmangled %]<a
+ href="${data.watch.$pkg.upstream_url}"
+ >${data.watch.$pkg.upstream_unmangled}</a>[%
+ ELSE %]${data.watch.$pkg.error}[% END %]</td>
</tr>
[% END #BLOCK package %]
More information about the Pkg-perl-cvs-commits
mailing list