r6650 - in /scripts/qa: Common.pm versioncheck2.pl
tincho-guest at users.alioth.debian.org
tincho-guest at users.alioth.debian.org
Wed Aug 15 10:17:36 UTC 2007
Author: tincho-guest
Date: Wed Aug 15 10:17:36 2007
New Revision: 6650
URL: http://svn.debian.org/wsvn/?sc=1&rev=6650
Log:
HUGE diff to versioncheck.pl:
- download of cpan, incoming and new data is now cached, the latter with low ttl
- processing of changelogs and watchfiles (and their parsing and uscanning!) is cached, issues a svn log to verify which files had changed
- lots of code moved around to allow this, so committing a new file.
- two new cmdline options: -force-cpan and -force-rescan, to invalidate the cpan and the debian/ files cache, respectively.
- Added my machine to Common.pm :)
Now, when there are no new changes, this runs in 0.6s in alioth, and a full run takes less that 10 seconds. So I think we can put this in a commit-hook.
Added:
scripts/qa/versioncheck2.pl (with props)
Modified:
scripts/qa/Common.pm
Modified: scripts/qa/Common.pm
URL: http://svn.debian.org/wsvn/scripts/qa/Common.pm?rev=6650&op=diff
==============================================================================
--- scripts/qa/Common.pm (original)
+++ scripts/qa/Common.pm Wed Aug 15 10:17:36 2007
@@ -41,6 +41,13 @@
/beetle/ && do {
$MIRROR = "http://localhost:9999";
$CPAN_MIRROR = "ftp://ftp.uni-sofia.bg/cpan";
+ last;
+ };
+
+ # Tincho
+ /abraxas/ && do {
+ $MIRROR = "file:///media/IOMega/mirror/";
+ $CPAN_MIRROR = "ftp://cpan.ip.pt/pub/cpan/";
last;
};
Added: scripts/qa/versioncheck2.pl
URL: http://svn.debian.org/wsvn/scripts/qa/versioncheck2.pl?rev=6650&op=file
==============================================================================
--- scripts/qa/versioncheck2.pl (added)
+++ scripts/qa/versioncheck2.pl Wed Aug 15 10:17:36 2007
@@ -1,0 +1,883 @@
+#!/usr/bin/perl -w
+# Copyright gregor herrmann <gregor+debian at comodo.priv.at>, 2007
+# Copyright Damyan Ivanov <dmn at debian.org>, 2007
+# Released under the terms of the GNU GPL 2
+
+### TODO ###
+#
+# Try harder to use 02packages.details.gz for authoritative CPAN
+# version source, regardless of whether debian/watch uses by-module URL
+# or by-author one
+#
+# Use AptPkg::Version for
+# - version comparison
+# - stripping debian revision off from a version
+
+our $THIS_REVISION = '$Id: versioncheck.pl 6423 2007-08-10 10:57:32Z dmn $';
+
+BEGIN {
+ my $self_dir = $0;
+ $self_dir =~ s{/[^/]+$}{};
+ unshift @INC, $self_dir;
+};
+
+use strict;
+use Common;
+use LWP::Simple ();
+use Compress::Zlib ();
+use HTML::TableExtract;
+use SVN::Client;
+use SVN::Core;
+use IO::Scalar;
+use Parse::DebianChangelog;
+use Getopt::Long;
+
+our $opt_debug = 0;
+my $force_cpan = 0;
+my $force_rescan = 0;
+
+GetOptions(
+ 'debug!' => \$opt_debug,
+ 'force-cpan!' => \$force_cpan,
+ 'force-rescan!' => \$force_rescan,
+);
+
+sub debugmsg(@)
+{
+ warn @_ if $opt_debug;
+};
+
+
+# Get some information globally
+
+use Storable();
+use LWP::UserAgent;
+
+debugmsg( "CPAN mirror is $CPAN_MIRROR\n" );
+debugmsg( "HOME=$ENV{HOME}\n" );
+
+sub from_cache($$$)
+{
+ my( $ref, $name, $max_age) = @_;
+
+ my $dir = $ENV{HOME}.'/.dpg/versioncheck';
+
+ return undef unless -f "$dir/$name" and -M(_) <= $max_age/24;
+
+ my $data = Storable::retrieve("$dir/$name");
+ return undef unless $data;
+
+ debugmsg("$name loaded from cache (".scalar(keys(%$data)).")\n");
+
+ %$ref = %$data;
+ return 1;
+}
+
+sub to_cache($$)
+{
+ my( $ref, $name) = @_;
+
+ my $home = $ENV{HOME};
+
+ -d "$home/.dpg" or mkdir("$home/.dpg") or die $!;
+ -d "$home/.dpg/versioncheck" or mkdir("$home/.dpg/versioncheck") or die $!;
+
+ Storable::store($ref, "$home/.dpg/versioncheck/$name");
+}
+
+sub scan_packages($$)
+{
+ my( $suite, $hash ) = @_;
+ foreach my $section ( qw( main contrib non-free ) )
+ {
+ # TODO This is somewhat brute-force, reading the whole sources into
+ # memory, then de-compressing them also in memory.
+ # Should be made incremental using reasonable-sized buffer
+ my $url = "$MIRROR/debian/dists/$suite/$section/source/Sources.gz";
+ my $sources_gz = LWP::Simple::get($url);
+ $sources_gz or die "Can't download $url";
+ my $sources = Compress::Zlib::memGunzip(\$sources_gz);
+ my $src_io = IO::Scalar->new(\$sources);
+
+ my $pkg;
+ while( <$src_io> )
+ {
+ chomp;
+ if( s/^Package: // )
+ {
+ $pkg = $_;
+ next;
+ }
+
+ if( s/^Version: // )
+ {
+ $hash->{$pkg} = $_;
+ }
+ }
+ }
+
+ debugmsg(
+ sprintf(
+ "Information about %d %s packages loaded\n",
+ scalar(keys(%$hash)),
+ $suite,
+ ),
+ );
+ to_cache($hash, $suite);
+}
+
+my %packages; # contains {package => version} pairs
+scan_packages(
+ 'unstable', \%packages,
+) unless from_cache(\%packages, 'unstable', 6);
+
+my %experimental; # contains {package => version} pairs
+scan_packages(
+ 'experimental', \%experimental,
+) unless from_cache(\%experimental, 'experimental', 6);
+
+my %stable; # contains {package => version} pairs
+scan_packages(
+ 'stable', \%stable,
+) unless from_cache(\%stable, 'stable', 168); # 1 week
+
+my %oldstable; # contains {package => version} pairs
+scan_packages(
+ 'oldstable', \%oldstable,
+) unless from_cache(\%oldstable, 'oldstable', 168); # 1 week
+
+my %incoming; # contains {package => version} pairs
+scan_incoming(
+ \%incoming,
+) unless from_cache(\%incoming, 'incoming', 1);
+
+my %new; # contains {package => version} pairs
+scan_new(
+ \%new,
+) unless from_cache(\%new, 'new', 1);
+
+my( %cpan_authors, %cpan_modules, $cpan_updated );
+unless(not $force_cpan and from_cache(\%cpan_authors, 'cpan_authors', 12)
+ and from_cache(\%cpan_modules, 'cpan_modules', 12))
+{
+ scan_cpan(\%cpan_authors, \%cpan_modules);
+ $cpan_updated = 1;
+}
+
+sub scan_incoming {
+ my $inchash = shift;
+ my $incoming = LWP::Simple::get('http://incoming.debian.org')
+ or die "Unable to retreive http://incoming.debian.org";
+ my $inc_io = IO::Scalar->new(\$incoming);
+ while( <$inc_io> )
+ {
+ chomp;
+ next unless /a href="([^_]+)_(.+)\.dsc"/;
+
+ $inchash->{$1} = $2;
+ }
+ to_cache($inchash, "incoming");
+ debugmsg( sprintf("Information about %d incoming packages loaded\n",
+ scalar(keys(%$inchash))) );
+};
+
+sub scan_new {
+ my $newhash = shift;
+ my $new = LWP::Simple::get('http://ftp-master.debian.org/new.html');
+ my $te = HTML::TableExtract->new(
+ headers=> [
+ qw(Package Version Arch Distribution Age Maintainer Closes)
+ ],
+ );
+ $te->parse($new);
+ foreach my $table( $te->tables )
+ {
+ foreach my $row( $table->rows )
+ {
+ next unless $row->[2] =~ /source/;
+
+ my @versions = split(/\n/, $row->[1]);
+ s/<br>// foreach @versions;
+
+ $newhash->{$row->[0]} = $versions[-1];# use the last uploaded version
+ }
+ }
+ to_cache($newhash, "new");
+ debugmsg( sprintf("Information about %d NEW packages loaded\n",
+ scalar(keys(%$newhash))) );
+}
+
+sub scan_cpan {
+ my( $cpauth, $cpmod ) = @_;
+ open(TMP, '+>', undef) or die "Unable to open anonymous temporary file";
+ my $old = select(TMP);
+ my $lslr = LWP::Simple::getprint("$CPAN_MIRROR/ls-lR.gz");
+ select($old);
+ seek(TMP, 0, 0);
+ my $gz = Compress::Zlib::gzopen(\*TMP, 'rb') or die $Compress::Zlib::gzerrno;
+
+ my $storage;
+ my ($section, $path);
+ while( $gz->gzreadline($_) )
+ {
+ chomp;
+ next unless $_;
+
+ if( m{^\./authors/id/(.+):} )
+ {
+ $storage = $cpauth->{$1} ||= [];
+ }
+ elsif( m{^\./modules/by-module/(.+):} )
+ {
+ $storage = $cpmod->{$1} ||= [];
+ }
+ elsif( m{\..*:} )
+ {
+ undef($storage);
+ }
+ else
+ {
+ next unless $storage;
+
+ my(
+ $perm, $ln, $o, $g, $size, $month, $day, $time, $what, $where,
+ ) = split(/\s+/);
+
+ next unless $what and $what =~ /(?:tar\.gz|\.tgz|\.zip|\.tar\.bz2|\.tbz)$/;
+
+ push @$storage, $what;
+ }
+ }
+ close(TMP);
+ to_cache($cpauth, 'cpan_modules');
+ to_cache($cpmod, 'cpan_authors');
+}
+
+# RETURNS
+# 1 if first version is bigger
+# 0 if both versions are equal
+# -1 if second version is bigger
+sub cmp_ver($$)
+{
+ my($a,$b) = @_;
+
+ while( $a and $b )
+ {
+ $a =~ s/^(\w*)//; my $a_w = $1||'';
+ $b =~ s/^(\w*)//; my $b_w = $1||'';
+
+ my $r = $a_w cmp $b_w;
+
+ return $r if $r;
+
+ $a =~ s/^(\d*)//; my $a_d = (defined($1) and $1 ne '') ? $1 : -1;
+ $b =~ s/^(\d*)//; my $b_d = (defined($1) and $1 ne '') ? $1 : -1;
+
+ $r = $a_d <=> $b_d;
+
+ return $r if $r;
+
+ $a =~ s/^(\D*)//; my $a_nd = $1||'';
+ $b =~ s/^(\D*)//; my $b_nd = $1||'';
+
+ $r = $a_nd cmp $b_nd;
+
+ return $r if $r;
+ }
+ return 1 if $a;
+ return -1 if $b;
+ return 0;
+}
+
+sub unmangle( $ $ )
+{
+ my( $ver, $mangles ) = @_;
+
+ return $ver unless $mangles;
+
+ my @vms = map( split(/;/, $_), @$mangles );
+
+ foreach my $vm( @vms )
+ {
+ eval "\$ver =~ $vm";
+ die "<<\$_ =~ $vm>> $@" if $@;
+ debugmsg(" mangled: $ver\n");
+ }
+
+ return $ver;
+}
+
+# RETURNS undef if all watch files point to CPAN
+sub latest_upstream_from_watch($)
+{
+ my ($watch) = @_;
+
+ my @vers;
+
+ foreach(@$watch)
+ {
+ my( $wline, $opts ) = @$_;
+
+ $wline =~ m{^(http://\S+)/};
+ 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};
+ if( $wline =~ m{
+ ^((?:http|ftp)://\S*?) # http://server/some/path - captured
+ # non-greedy to not eat up the pattern
+ (?:/\s*|\s+) # delimiter - '/' for ver3 or space for ver2
+ ([^\s/]+) # the search pattern - no spaces, no slashes - captured
+ (?:
+ (?!.*\() # followed by non-(search pattern)
+ |
+ \s*$ # or EOL
+ )
+ }ix )
+ {
+ my( $dir, $filter ) = ($1, $2);
+ debugmsg( " uscan $dir $filter\n" );
+ $url ||= $dir;
+ my $page = LWP::Simple::get($dir) or return "Unable to get $dir (".__LINE__.")";
+ my $page_io = IO::Scalar->new(\$page);
+ while( <$page_io> )
+ {
+ warn $_ if 0;
+
+ if( $dir =~ /^http/ )
+ {
+ while( s/<a [^>]*href="([^"]+)"[^>]*>// )
+ {
+ my $href = $1;
+ push @vers, [
+ unmangle( $1, $opts->{uversionmangle} ),
+ $url,
+ ] if $href =~ $filter;
+ }
+ }
+ else
+ {
+ while( s/(?:^|\s+)$filter(?:\s+|$)// )
+ {
+ push @vers, [
+ unmangle( $1, $opts->{uversionmangle} ),
+ $url,
+ ];
+ }
+ }
+ }
+ }
+ else
+ {
+ return "bad watch URL $wline";
+ }
+ }
+
+ @vers = sort { cmp_ver($a->[0],$b->[0]) } @vers;
+
+ my $ver = $vers[-1];
+ my $url;
+
+ ($ver, $url) = $ver ? @$ver : (undef, undef);
+
+ return wantarray ? ($ver, $url) : $ver;
+}
+
+# returns array of [ver, path]
+sub cpan_versions($$$)
+{
+ my($where, $wline, $opts) = @_;
+
+ $wline =~ m{
+ ^(\S*?) # some/path - captured
+ # non-greedy to not eat up the pattern
+ (?:/\s*|\s+) # delimiter - '/' for ver3 or space for ver2
+ ([^\s/]+) # the search pattern - no spaces, no slashes - captured
+ (?!.*\() # not followed by search pattern
+ }ix;
+ my( $key, $filter) = ($1, $2);
+ debugmsg( sprintf( " module search %s %s\n", $key, $filter ) );
+
+ my $list = $where->{$key};
+ unless($list)
+ {
+ debugmsg("directory $key not found (from $wline) [".__LINE__."]\n");
+ return();
+ }
+
+ my @vers;
+ foreach(@$list)
+ {
+ if( $_ =~ $filter )
+ {
+ debugmsg(" looking at $_\n") if 1;
+ my $ver = unmangle( $1, $opts->{uversionmangle} );
+ push @vers, [$ver, $key];
+ }
+ }
+
+ return @vers;
+}
+
+# returns (version, URL)
+sub latest_upstream_from_cpan($$$)
+{
+ my ($watch, $cpauth, $cpmod) = @_;
+
+ my @cpan = grep( $_->[0] =~ m{(?:^|\s)(?:http|ftp)://\S*cpan}i, @$watch );
+
+ return undef unless @cpan;
+
+ my @vers;
+
+ foreach(@cpan)
+ {
+ my( $wline, $opts ) = @$_;
+ if( $wline =~ s{^(?:http|ftp)://\S*cpan\S*/modules/by-module/}{}i )
+ {
+ # lookup by module
+ push @vers, map(
+ [ $_->[0], "http://www.cpan.org/modules/by-module/".$_->[1] ],
+ cpan_versions($cpmod, $wline, $opts),
+ );
+ }
+ elsif( $wline =~ s{^(?:http|ftp)://\S*cpan\S*/authors/(?:by-)?id/}{}i
+ or
+ $wline =~ s{^(?:http|ftp)://\S*cpan\S*/(?:by-)?authors/id/}{}i
+ )
+ {
+ # lookup by author
+ push @vers, map(
+ [ $_->[0], "http://www.cpan.org/authors/id/".$_->[1] ],
+ cpan_versions($cpauth, $wline, $opts),
+ );
+ }
+ else
+ {
+ debugmsg( sprintf( " can't determine type of search for %s\n", $wline ) );
+ return undef;
+ }
+ }
+
+ @vers = sort { cmp_ver($a->[0],$b->[0]) } @vers;
+
+ my $ver = $vers[-1];
+ my $url;
+ if( $ver )
+ {
+ ($ver, $url) = @$ver;
+ }
+ else
+ {
+ undef($ver); undef($url);
+ }
+
+ return wantarray ? ($ver, $url) : $ver;
+}
+
+sub unmangle_debian_version($$)
+{
+ my($ver, $watch) = @_;
+
+ foreach( @$watch )
+ {
+ my $dvm = $_->[1]->{dversionmangle} if $_->[1];
+ $dvm ||= [];
+
+ do {
+ eval "\$ver =~ $_";
+ die "\$ver =~ $dvm -> $@" if $@;
+ } foreach @$dvm;
+ }
+
+ return $ver;
+}
+
+sub read_changelog ($) {
+ my( $dir ) = @_;
+ debugmsg("Retrieving changelog for $dir\n" );
+
+ my $changelog;
+ my $svn_error;
+ my $svn = SVN::Client->new();
+ {
+ my $changelog_fh = IO::Scalar->new( \$changelog );
+ local $SVN::Error::handler = undef;
+ ($svn_error) = $svn->cat(
+ $changelog_fh,
+ "$SVN_REPO/trunk/$dir/debian/changelog",
+ 'HEAD',
+ );
+ }
+ if(SVN::Error::is_error($svn_error))
+ {
+ if($svn_error->apr_err() == $SVN::Error::FS_NOT_FOUND)
+ {
+ $svn_error->clear();
+ }
+ else
+ {
+ SVN::Error::croak_on_error($svn_error);
+ }
+ }
+ if(! $changelog) {
+ return { chl_ver => "Missing changelog" };
+ }
+
+ foreach( Parse::DebianChangelog->init({instring=>$changelog})->data )
+ {
+ next unless $_->Distribution eq 'unstable';
+ next if $_->Changes =~ /NOT RELEASED/;
+
+ return {
+ chl_ver => $_->Version,
+ chl_changer => $_->Maintainer,
+ chl_date => $_->Date,
+ chl_pkg => $_->Source,
+ chl_native => scalar($_->Version !~ /-./)
+ };
+ }
+ return { chl_ver => "Invalid changelog" };
+}
+sub read_watch ($) {
+ my( $dir ) = @_;
+ debugmsg("Retrieving watch for $dir\n" );
+
+ my $svn_error;
+ my $svn = SVN::Client->new();
+ my $watch;
+ {
+ my $watch_io = IO::Scalar->new(\$watch);
+ local $SVN::Error::handler = undef;
+ ($svn_error) = $svn->cat(
+ $watch_io,
+ "$SVN_REPO/trunk/$dir/debian/watch",
+ 'HEAD',
+ );
+ $watch_io->close();
+ }
+ if(SVN::Error::is_error($svn_error))
+ {
+ if($svn_error->apr_err() == $SVN::Error::FS_NOT_FOUND)
+ {
+ $svn_error->clear();
+ }
+ else
+ {
+ SVN::Error::croak_on_error($svn_error);
+ }
+ }
+ if( not $watch) {
+ return 'missing';
+ }
+
+ $watch =~ s/\\\n//gs;
+ my @watch_lines = split(/\n/, $watch) if $watch;
+ @watch_lines = grep( (!/^#/ and !/^version=/ and !/^\s*$/), @watch_lines );
+
+ my @watch;
+ foreach(@watch_lines)
+ {
+ debugmsg( " watch line $_\n" ) if 0;
+ # opts either contain no spaces, or is enclosed in double-quotes
+ my $opts = $1 if s!^\s*opts="([^"]*)"\s+!! or s!^\s*opts=(\S*)\s+!!;
+ debugmsg( " watch options = $opts\n" ) if $opts;
+ # several options are separated by comma and commas are not allowed within
+ my @opts = split(/\s*,\s*/, $opts) if $opts;
+ my %opts;
+ foreach(@opts)
+ {
+ next if /^(?:active|passive|pasv)$/;
+
+ /([^=]+)=(.*)/;
+ debugmsg( " watch option $1 = $2\n" );
+ if( $1 eq 'versionmangle' )
+ {
+ push @{ $opts{uversionmangle} }, $2;
+ push @{ $opts{dversionmangle} }, $2;
+ }
+ else
+ {
+ push @{ $opts{$1} }, $2;
+ }
+ }
+ s!^http://www.cpan.org/!$CPAN_MIRROR/!;
+ s!^ftp://www.cpan.org/!$CPAN_MIRROR/!;
+ s!^http://backpan.perl.org/authors/!$CPAN_MIRROR/authors/!;
+ s!^http://mirrors.kernel.org/cpan/!$CPAN_MIRROR/!;
+ s!^ftp://mirrors.kernel.org/cpan/!$CPAN_MIRROR/!;
+
+ push @watch, [ $_, \%opts ];
+ }
+
+ if( not @watch )
+ {
+ return 'invalid';
+ }
+ return ( 'valid', @watch );
+}
+
+my $header = <<_EOF;
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
+ "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+ <title>pkg-perl package versions</title>
+ <style type="text/css">
+ body {
+ background: white;
+ color: black;
+ }
+ table {
+ border: 1px solid black;
+ border-collapse: collapse;
+ empty-cells: show;
+ }
+ td, th {
+ border: 1px solid black;
+ }
+ .upload {
+ background: lightsalmon;
+ }
+ .upgrade {
+ background: lightblue;
+ }
+ </style>
+</head>
+<body>
+<table>
+<tr><th>Legend</th></tr>
+<tr><td class="upload">Needs uploading</td></tr>
+<tr><td class="upgrade">Needs upgrade from upstream</td></tr>
+</table>
+
+<br>
+
+<table>
+<tr>
+ <th>Package</th>
+ <th>Repository</th>
+ <th>Archive</th>
+ <th>upstream</th>
+</tr>
+_EOF
+
+my $total = 0;
+my $total_shown = 0;
+my $chunk;
+
+# loop over packages
+my $svn = SVN::Client->new();
+my @svn_packages = sort(keys(%{$svn->ls("$SVN_REPO/trunk", 'HEAD', 0)}));
+my $cur_ver;
+$svn->info("$SVN_REPO/trunk", undef, "HEAD", sub {
+ $cur_ver = $_[1]->rev();
+ }, 0);
+
+my %maindata;
+my(@wmodified, @cmodified);
+if(not $force_rescan and from_cache(\%maindata, "maindata", 168)) { # 1 week
+ $svn->log( ["$SVN_REPO/trunk"], $maindata{lastrev}, "HEAD", 1, 1, sub {
+ foreach(keys %{$_[0]}) {
+ if(m{^/?trunk/([^/]+)/debian/(changelog|watch)$}) {
+ if($2 eq "changelog") {
+ push @cmodified, $1;
+ } else {
+ push @wmodified, $1;
+ }
+ }
+ }
+ }
+ );
+} else {
+ $maindata{packages} = {};
+}
+$maindata{lastrev} = $cur_ver;
+foreach(@svn_packages) {
+ next if($maindata{packages}{$_});
+ $maindata{packages}{$_} = {};
+ push @wmodified, $_;
+ push @cmodified, $_;
+}
+my %tmp = map({ $_ => 1 } @cmodified); # eliminate dupes
+foreach my $pkg (keys %tmp) {
+ $maindata{packages}{$pkg} ||= {};
+ foreach(keys %{$maindata{packages}{$pkg}}) {
+ delete $maindata{packages}{$pkg}{$_} if(/^chl_/);
+ }
+ my $data = read_changelog($pkg);
+ foreach(keys %$data) {
+ $maindata{packages}{$pkg}{$_} = $data->{$_};
+ }
+}
+if($cpan_updated) {
+ push @wmodified, grep(
+ { $maindata{packages}{$_}{watch_cpan} }
+ @svn_packages );
+}
+%tmp = map({ $_ => 1 } @wmodified); # eliminate dupes
+foreach(keys %tmp) {
+ my $pkg = $maindata{packages}{$_};
+ my($st, @data) = read_watch($_);
+ foreach(keys %{$pkg}) {
+ delete $pkg->{$_} if(/^watch_/);
+ }
+ $pkg->{watch_url} = "";
+ $pkg->{watch_ver} = "";
+ $pkg->{watch_unmangled_ver} = $pkg->{chl_ver};
+ unless($st eq "valid") {
+ if($st eq "missing" and $pkg->{chl_native}) {
+ $pkg->{watch_ver} = $pkg->{chl_ver};
+ } elsif($st eq "invalid") {
+ $pkg->{watch_ver} = "Invalid debian/watch";
+ $pkg->{watch_url} = qq(http://svn.debian.org/wsvn/pkg-perl/trunk/$_/debian/watch?op=file&rev=0&sc=0);
+ } else { # missing
+ $pkg->{watch_ver} = "Missing debian/watch";
+ }
+ next;
+ }
+ $pkg->{watch} = \@data;
+
+ my($upstream_ver, $upstream_url) = latest_upstream_from_cpan(\@data,
+ \%cpan_authors, \%cpan_modules);
+ if( $upstream_ver ) {
+ $pkg->{watch_cpan} = 1;
+ } else {
+ ($upstream_ver, $upstream_url) = latest_upstream_from_watch(\@data);
+ }
+ if( $upstream_ver ) {
+ $pkg->{watch_ver} = $upstream_ver;
+ $pkg->{watch_url} = $upstream_url || "";
+ } else {
+ $pkg->{watch_ver} = "Invalid debian/watch";
+ $pkg->{watch_url} = qq(http://svn.debian.org/wsvn/pkg-perl/trunk/$_/debian/watch?op=file&rev=0&sc=0);
+ }
+ if($pkg->{chl_ver}) {
+ my $up_svn = $pkg->{chl_ver};
+ $up_svn =~ s/^(?:\d+:)?(.+?)(?:-[^-]+)?$/$1/;
+ $up_svn = unmangle_debian_version($up_svn, \@data);
+ $pkg->{watch_unmangled_ver} = $up_svn;
+ }
+}
+to_cache(\%maindata, "maindata");
+
+my @pkgs_to_check;
+if( @ARGV )
+{
+ @pkgs_to_check = @ARGV;
+}
+else
+{
+ debugmsg(
+ sprintf(
+ "%d entries in trunk\n",
+ scalar(@svn_packages)
+ ),
+ );
+ @pkgs_to_check = @svn_packages;
+}
+
+print $header;
+foreach ( @pkgs_to_check )
+{
+ $total++;
+
+ debugmsg("Examining $_\n" );
+ my $pkg = $maindata{packages}{$_};
+
+ debugmsg(sprintf(" - Archive has %s\n", $packages{$_} || 'none'));
+ debugmsg(sprintf(" - experimental has %s\n",
+ $experimental{$pkg} || 'none'));
+ debugmsg(sprintf(" - stable has %s\n", $stable{$pkg} || 'none'));
+ debugmsg(sprintf(" - oldstable has %s\n", $oldstable{$pkg} || 'none'));
+ debugmsg(sprintf(" - incoming has %s\n", $incoming{$pkg} || 'none' ));
+ debugmsg(sprintf(" - NEW has %s\n", $new{$pkg} || 'none'));
+ debugmsg(sprintf(" - %s has %s (%s)\n",
+ $pkg->{watch_cpan} ? "CPAN" : "upstream",
+ $pkg->{watch_ver} || 'none', $pkg->{watch_url} || 'no url'));
+ debugmsg(sprintf(" - SVN has %s (upstream version=%s)\n",
+ $pkg->{chl_ver} || 'none', $pkg->{watch_unmangled_ver} || 'none'));
+
+ next unless(
+ $pkg->{watch_unmangled_ver} ne $pkg->{watch_ver}
+ or
+ (! $packages{$_} or $pkg->{chl_ver} ne $packages{$_})
+ and
+ (! $incoming{$_} or $pkg->{chl_ver} ne $incoming{$_})
+ and
+ (! $new{$_} or $pkg->{chl_ver} ne $new{$_})
+ );
+ $total_shown++;
+ my $text = "<tr>\n";
+ $text .= "<td>$_</td>\n";
+
+ $text .= "<td".(
+ (! $packages{$_} or $pkg->{chl_ver} ne $packages{$_})
+ ? ' class="upload">'
+ : '>');
+ $text .= qq(<a href="http://svn.debian.org/wsvn/pkg-perl/trunk/$_/debian/changelog?op=file&rev=0&sc=0" title=") . $pkg->{chl_changer} . "\n" . $pkg->{chl_date} . "\">" .$pkg->{chl_ver} . "</a></td>\n";
+
+ my $archive_text = join(
+ "\n",
+ $packages{$_}||(),
+ (
+ ($incoming{$_})
+ ? "Incoming: $incoming{$_}"
+ : ()
+ ),
+ (
+ ($new{$_})
+ ? "NEW: $new{$_}"
+ : ()
+ ),
+ (
+ ($experimental{$_})
+ ? "experimental: $experimental{$_}"
+ : ()
+ ),
+ (
+ ($stable{$_} and not $packages{$_} and not $experimental{$_})
+ ? "stable: $stable{$_}"
+ : ()
+ ),
+ (
+ ($oldstable{$_} and not $stable{$_} and not $packages{$_} and not $experimental{$_})
+ ? "oldstable: $oldstable{$_}"
+ : ()
+ ),
+ );
+
+ $archive_text = qq(<a href="http://packages.qa.debian.org/$_">$archive_text</a> [<a style="font-size:smaller" href="http://bugs.debian.org/src:$_">BTS</a>]) if $packages{$_} or $experimental{$_} or $stable{$_} or $oldstable{$_};
+
+ $text .= "<td>$archive_text</td>\n";
+
+ my $upstream_text = (
+ $pkg->{watch_cpan} ? "CPAN: " : "") . $pkg->{watch_ver};
+ $upstream_text = qq(<a href=") . $pkg->{watch_url} . qq(">$upstream_text</a>) if $pkg->{watch_url};
+
+ $text .= (
+ ($pkg->{watch_unmangled_ver} ne $pkg->{watch_ver})
+ ? qq(<td class="upgrade">$upstream_text</td>\n)
+ : "<td></td>\n"
+ );
+ $text .= "</tr>\n";
+ print $text;
+}
+
+
+my $date = gmtime;
+my $footer = <<_EOF;
+<tr><td colspan=\"4\"><b>TOTAL: $total_shown/$total</b></td></tr>
+</table>
+<hr>
+$date UTC<br>
+<i>$THIS_REVISION</i>
+</body>
+_EOF
+
+print $footer;
+
+exit 0;
+
+# vim: et:sts=4:ai:sw=4
Propchange: scripts/qa/versioncheck2.pl
------------------------------------------------------------------------------
svn:executable = *
More information about the Pkg-perl-cvs-commits
mailing list