r8610 - /scripts/qa/versioncheck3.pl
gregoa-guest at users.alioth.debian.org
gregoa-guest at users.alioth.debian.org
Sat Oct 27 15:49:52 UTC 2007
Author: gregoa-guest
Date: Sat Oct 27 15:49:52 2007
New Revision: 8610
URL: http://svn.debian.org/wsvn/?sc=1&rev=8610
Log:
versioncheck3.pl: adds additional column 'Bugs' which shows the number of open bugs per package; uses the SOAP interface of the BTS
Added:
scripts/qa/versioncheck3.pl (with props)
Added: scripts/qa/versioncheck3.pl
URL: http://svn.debian.org/wsvn/scripts/qa/versioncheck3.pl?rev=8610&op=file
==============================================================================
--- scripts/qa/versioncheck3.pl (added)
+++ scripts/qa/versioncheck3.pl Sat Oct 27 15:49:52 2007
@@ -1,0 +1,1094 @@
+#!/usr/bin/perl -w
+# Copyright gregor herrmann <gregor+debian at comodo.priv.at>, 2007
+# Copyright Damyan Ivanov <dmn at debian.org>, 2007
+# Copyright MartÃn Ferrari <martin.ferrari at gmail.com>, 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: versioncheck2.pl 8560 2007-10-24 19:32:31Z dmn $';
+
+BEGIN {
+ my $self_dir = $0;
+ $self_dir =~ s{/[^/]+$}{};
+ unshift @INC, $self_dir;
+};
+
+use strict;
+use Carp qw(confess);
+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;
+use File::Path;
+use SOAP::Lite;
+
+our $opt_debug = 0;
+my $force_cpan = 0;
+my $force_rescan = 0;
+my @pkg_rescan = ();
+our $CACHEDIR = "$ENV{HOME}/.dpg/versioncheck";
+our $svn = SVN::Client->new();
+
+GetOptions(
+ 'debug!' => \$opt_debug,
+ 'force-cpan!' => \$force_cpan,
+ 'force-rescan!' => \$force_rescan,
+ 'rescan=s' => \@pkg_rescan,
+ 'cache-dir=s' => \$CACHEDIR
+);
+
+sub debugmsg(@)
+{
+ warn @_ if $opt_debug;
+};
+
+mkpath $CACHEDIR;
+my $lockfile = "$CACHEDIR/.lock";
+if(-e $lockfile) {
+ if(-M $lockfile > 1/24) { # 1 hour
+ debugmsg("Stale lock file -- deleting\n");
+ unlink $lockfile or die $!;
+ } else {
+ die("Other instance of $0 is running!\n");
+ }
+}
+$SIG{HUP} = $SIG{INT} = $SIG{QUIT} = \&sighandler;
+$SIG{SEGV} = $SIG{PIPE} = $SIG{TERM} = \&sighandler;
+$SIG{__DIE__} = \&diehandler;
+open(LOCK, ">", $lockfile) or die $!;
+close(LOCK) or die $!;
+
+# Get some information globally
+
+use Storable();
+use LWP::UserAgent;
+
+debugmsg( "CPAN mirror is $CPAN_MIRROR\n" );
+debugmsg( "The cache is in $CACHEDIR\n" );
+
+sub diehandler
+{
+ die @_ if($^S); # eval
+ debugmsg("Removing lockfile...\n");
+ unlink $lockfile;
+ die @_;
+}
+sub sighandler
+{
+ my $sig = shift;
+ warn "Caught $sig signal...\n";
+ debugmsg("Removing lockfile...\n");
+ unlink $lockfile;
+ # signal myself again
+ $SIG{$sig} = "DEFAULT";
+ kill $sig, $$;
+}
+sub from_cache($$$)
+{
+ my( $ref, $name, $max_age) = @_;
+
+ my $dir = $CACHEDIR;
+
+ 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) = @_;
+
+ Storable::store($ref, "$CACHEDIR/$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);
+ unless($sources_gz) {
+ warn "Can't download $url";
+ return 0;
+ }
+ 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);
+ 1;
+}
+
+my %packages; # contains {package => version} pairs
+unless(from_cache(\%packages, 'unstable', 6)) {
+ scan_packages('unstable', \%packages)
+ or from_cache(\%packages, 'unstable', 999) or die;
+}
+
+my %experimental; # contains {package => version} pairs
+unless(from_cache(\%experimental, 'experimental', 6)) {
+ scan_packages('experimental', \%experimental)
+ or from_cache(\%experimental, 'experimental', 999) or die;
+}
+
+my %stable; # contains {package => version} pairs
+unless(from_cache(\%stable, 'stable', 168)) {
+ scan_packages('stable', \%stable)
+ or from_cache(\%stable, 'stable', 999) or die;
+}
+
+my %oldstable; # contains {package => version} pairs
+unless(from_cache(\%oldstable, 'oldstable', 168)) {
+ scan_packages('oldstable', \%oldstable)
+ or from_cache(\%oldstable, 'oldstable', 999) or die;
+}
+
+my %incoming; # contains {package => version} pairs
+unless(from_cache(\%incoming, 'incoming', 1)) {
+ scan_incoming(\%incoming)
+ or from_cache(\%incoming, 'incoming', 999) or die;
+}
+
+my %new; # contains {package => version} pairs
+unless(from_cache(\%new, 'new', 1)) {
+ scan_new(\%new)
+ or from_cache(\%new, 'new', 999) or die;
+}
+
+my %bugs; # contains {package => bugcount} pairs
+unless(from_cache(\%bugs, 'bugs', 6)) {
+ scan_bugs(\%bugs)
+ or from_cache(\%new, 'new', 999) or die;
+}
+
+my( %cpan_authors, %cpan_modules, %cpan_dists, $cpan_updated );
+unless(not $force_cpan
+ and from_cache(\%cpan_authors, 'cpan_authors', 12)
+ and from_cache(\%cpan_modules, 'cpan_modules', 12)
+ and from_cache(\%cpan_dists, 'cpan_dists', 12))
+{
+ if(scan_cpan(\%cpan_authors, \%cpan_modules, \%cpan_dists)) {
+ $cpan_updated = 1;
+ } else {
+ from_cache(\%cpan_authors, 'cpan_authors', 999) or die;
+ from_cache(\%cpan_modules, 'cpan_modules', 999) or die;
+ from_cache(\%cpan_dists, 'cpan_dists', 999) or die;
+ }
+}
+
+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_bugs {
+ my $bughash = shift;
+
+ my $soap = SOAP::Lite->uri('Debbugs/SOAP')->proxy('http://bugs.debian.org/cgi-bin/soap.cgi');
+ my $pkgperlbugs = $soap->get_bugs(maint=>'pkg-perl-maintainers at lists.alioth.debian.org')->result();
+ foreach my $bug(@$pkgperlbugs) {
+ my $status = $soap->get_status($bug)->result->{$bug};
+ my $pkgname = $status->{package};
+ my $done = $status->{done};
+ $bughash->{$pkgname}++ unless $done;
+ }
+
+ to_cache($bughash, "bugs");
+ debugmsg( sprintf("Information about bugs for %d packages loaded\n",
+ scalar(keys(%$bughash))) );
+}
+
+sub scan_cpan {
+ my( $cpauth, $cpmod, $cpdist ) = @_;
+ 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");
+ unless(-s TMP) {
+ close TMP;
+ return 0;
+ }
+ 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 $_;
+
+ # catch dist
+ if( m{
+ \s # blank
+ ( # $1 will capture the whole file name
+ (\S+?) # dist name - in $2
+ - # separator - dash
+ v? # optional 'v' before the version
+ (?: # version
+ \d # starts with a digit
+ [\d._]+ # followed by digits, periods and underscores
+ )
+ (?: # file extension
+ \.tar # .tar
+ (?:\.gz)? # most probably followed with .gz
+ | \.zip # yeah, that ugly OS is not wiped yet
+ )
+ )$}x # and this finishes the line
+ )
+ {
+ $cpdist->{$2} ||= [];
+ push @{ $cpdist->{$2} }, $1;
+ }
+
+ 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_authors');
+ to_cache($cpmod, 'cpan_modules');
+ to_cache($cpdist, 'cpan_dists' );
+ 1;
+}
+
+# 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|ftp)://\S+)/};
+ my $url = $1 or confess "Invalid watch line given? '$wline'";
+ $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);
+
+ my( $dir, $filter );
+
+ # Either we have single URL/pattern
+ # or URL/pattern + extra
+ if( $items[0] =~ /\(/ )
+ {
+ # Since '+' is greedy, the second capture has no slashes
+ ($dir, $filter) = $items[0] =~ m{^(.+)/(.+)$};
+ }
+ # or, we have a homepage plus pattern
+ # (plus optional other non-interesting stuff)
+ elsif( @items >= 2 and $items[1] =~ /\(/ )
+ {
+ ($dir, $filter) = @items[0,1];
+ }
+
+ if( $dir and $filter )
+ {
+ 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="([^"]+)"[^>]*>//i )
+ {
+ 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) = @_;
+
+ my( $key, $filter );
+ # watch line is either:
+ # path/pattern
+ # or
+ # path pattern
+ my @elements = split(/\s+/, $wline);
+ # ignore version and script for version=2 watchlines
+ # (consider the first element only unless the second contains a capture)
+ @elements = $elements[0] if $elements[1] and $elements[1] !~ m{\(};
+ if( @elements == 1 )
+ { # "path/pattern"
+ $wline =~ m{
+ ^(\S*?) # some/path - captured
+ # non-greedy to not eat up the pattern
+ / # delimiter - '/'
+ ([^\s/]+) # the search pattern - no spaces, no slashes - captured
+ (?!.*\() # not followed by search pattern
+ }ix
+ and
+ ( $key, $filter ) = ($1, $2)
+ or
+ die "Strange one-element watchline '$wline'";
+ }
+ else
+ { # "path" "pattern" "other things" (ignored)
+ ( $key, $filter ) = @elements[0..1];
+
+ # could this be a dist search?
+ if ( $key =~ m{^http://search.cpan.org/dist/([^/]+)/$} )
+ {
+ $key = $1;
+ $filter =~ s{^.*/}{}; # remove prepended paths
+ }
+ else
+ {
+ # remove trailing slash (if present)
+ $key =~ s{/$}{};
+ }
+ }
+
+ 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 0;
+ my $ver = unmangle( $1, $opts->{uversionmangle} );
+ push @vers, [$ver, $key];
+ }
+ }
+
+ return @vers;
+}
+
+# returns (version, URL)
+sub latest_upstream_from_cpan($$$$)
+{
+ my ($watch, $cpauth, $cpmod, $cpdist) = @_;
+
+ 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),
+ );
+ }
+ elsif( $wline =~ m{(?:http|ftp)://search.cpan.org/dist/([^/]+)/?\s} )
+ {
+ # lookup by dist
+ my $dist = $1;
+ push @vers, map(
+ [ $_->[0], "http://search.cpan.org/dist/$dist/" ],
+ cpan_versions($cpdist, $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 $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" };
+ }
+
+ my @chl = Parse::DebianChangelog->init({instring=>$changelog})->data;
+ my @validchl = grep({ $_->Distribution eq 'unstable' and
+ $_->Changes !~ /NOT RELEASED/ } @chl);
+ my($chl, $ver);
+ if(@validchl) {
+ $chl = shift @validchl;
+ $ver = $chl->Version;
+ } elsif(@chl) {
+ $chl = shift @chl;
+ $ver = "Unreleased";
+ } else {
+ return { chl_ver => "Invalid changelog" };
+ }
+ return {
+ chl_ver => $ver,
+ chl_changer => $chl->Maintainer,
+ chl_date => $chl->Date,
+ chl_pkg => $chl->Source,
+ chl_native => scalar($chl->Version !~ /-./)
+ };
+}
+sub read_watch ($) {
+ my( $dir ) = @_;
+ debugmsg("Retrieving watch for $dir\n" );
+
+ my $svn_error;
+ 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 )
+ {
+ warn "invalid debian/watch" if 0;
+ return 'invalid';
+ }
+ debugmsg('Found valid debian/watch') if 0;
+ 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;
+ }
+ .bugs {
+ background: lightseagreen;
+ }
+ .upgrade {
+ background: lightblue;
+ }
+ </style>
+</head>
+<body>
+<table>
+<tr>
+<td>
+<table>
+<tr><th>Legend</th></tr>
+<tr><td class="upload">Needs uploading</td></tr>
+<tr><td class="bugs">Needs bug fixing</td></tr>
+<tr><td class="upgrade">Needs upgrade from upstream</td></tr>
+</table>
+</td>
+<td>
+ <a href="http://pkg-perl.alioth.debian.org/">http://pkg-perl.alioth.debian.org</a>
+</td>
+</tr>
+</table>
+
+<br>
+
+<table>
+<tr>
+ <th>Package</th>
+ <th>Repository</th>
+ <th>Archive</th>
+ <th>Bugs</th>
+ <th>Upstream</th>
+</tr>
+_EOF
+
+my $total = 0;
+my $total_shown = 0;
+my $chunk;
+
+# loop over packages
+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
+ if($maindata{packages}) {
+ debugmsg("Converting maindata hash\n");
+ my %md;
+ $md{"//lastrev"} = $maindata{lastrev};
+ $md{$_} = $maindata{packages}{$_} foreach(
+ keys %{$maindata{packages}});
+ %maindata = %md;
+ }
+ $svn->log( ["$SVN_REPO/trunk"], $maindata{"//lastrev"}, "HEAD", 1, 1, sub {
+ return if($_[1] <= $maindata{"//lastrev"});
+ debugmsg("Scanning changes from revision $_[1]:\n");
+ foreach(keys %{$_[0]}) {
+ debugmsg("- $_\n");
+ if(m{^/?trunk/([^/]+)/debian/(changelog|watch)$}) {
+ if($2 eq "changelog") {
+ push @cmodified, $1;
+ } else {
+ push @wmodified, $1;
+ }
+ }
+ }
+ }
+ );
+}
+$maindata{"//lastrev"} = $cur_ver;
+foreach(@pkg_rescan) { # forced rescan of packages
+ push @wmodified, $_;
+ push @cmodified, $_;
+}
+foreach(@svn_packages) {
+ next if($maindata{$_});
+ $maindata{$_} = {};
+ push @wmodified, $_;
+ push @cmodified, $_;
+}
+my %tmp = map({ $_ => 1 } @cmodified); # eliminate dupes
+foreach my $pkg (keys %tmp) {
+ $maindata{$pkg} ||= {};
+ foreach(keys %{$maindata{$pkg}}) {
+ delete $maindata{$pkg}{$_} if(/^chl_/);
+ }
+ my $data = read_changelog($pkg);
+ foreach(keys %$data) {
+ $maindata{$pkg}{$_} = $data->{$_};
+ }
+ delete $maindata{$pkg}{watch_unmangled_ver};
+ if($maindata{$pkg}{chl_ver} and $maindata{$pkg}{watch}) {
+ my $up_svn = $maindata{$pkg}{chl_ver};
+ $up_svn =~ s/^(?:\d+:)?(.+?)(?:-[^-]+)?$/$1/;
+ $up_svn = unmangle_debian_version($up_svn, $maindata{$pkg}{watch});
+ $maindata{$pkg}{watch_unmangled_ver} = $up_svn;
+ }
+}
+if($cpan_updated) {
+ push @wmodified, grep(
+ { $maindata{$_}{watch_cpan} }
+ @svn_packages );
+}
+%tmp = map({ $_ => 1 } @wmodified); # eliminate dupes
+foreach(keys %tmp) {
+ my $pkg = $maindata{$_};
+ my($st, @data) = read_watch($_);
+ debugmsg("$_: $st ".scalar(@data)) if 0;
+ 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, \%cpan_dists);
+ 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;
+my $showalways;
+if( @ARGV )
+{
+ @pkgs_to_check = @ARGV;
+ $showalways = 1;
+}
+else
+{
+ debugmsg(
+ sprintf(
+ "%d entries in trunk\n",
+ scalar(@svn_packages)
+ ),
+ );
+ @pkgs_to_check = @svn_packages;
+}
+
+print $header;
+foreach ( @pkgs_to_check )
+{
+ $total++;
+
+ my $pkgd = $maindata{$_};
+ my $spkg = $maindata{$_}{chl_pkg} or die "No source package for $_?";
+ debugmsg("Examining $_ (src:$spkg)\n" );
+
+ debugmsg(sprintf(" - Archive has %s\n", $packages{$spkg} || 'none'));
+ debugmsg(sprintf(" - experimental has %s\n",
+ $experimental{$spkg} || 'none'));
+ debugmsg(sprintf(" - stable has %s\n", $stable{$spkg} || 'none'));
+ debugmsg(sprintf(" - oldstable has %s\n", $oldstable{$spkg} || 'none'));
+ debugmsg(sprintf(" - incoming has %s\n", $incoming{$spkg} || 'none' ));
+ debugmsg(sprintf(" - NEW has %s\n", $new{$spkg} || 'none'));
+ debugmsg(sprintf(" - Bug number: %d\n", $bugs{$spkg} || 'none'));
+ debugmsg(sprintf(" - %s has %s (%s)\n",
+ $pkgd->{watch_cpan} ? "CPAN" : "upstream",
+ $pkgd->{watch_ver} || 'none', $pkgd->{watch_url} || 'no url'));
+ debugmsg(sprintf(" - SVN has %s (upstream version=%s)\n",
+ $pkgd->{chl_ver} || 'none', $pkgd->{watch_unmangled_ver} || 'none'));
+
+ next unless($showalways or
+ $pkgd->{watch_unmangled_ver} ne $pkgd->{watch_ver}
+ or
+ ($bugs{$spkg} and $bugs{$spkg} > 0)
+ or
+ (! $packages{$spkg} or $pkgd->{chl_ver} ne $packages{$spkg})
+ and
+ (! $incoming{$spkg} or $pkgd->{chl_ver} ne $incoming{$spkg})
+ and
+ (! $new{$spkg} or $pkgd->{chl_ver} ne $new{$spkg})
+ );
+ $total_shown++;
+ my $text = "<tr>\n";
+ $text .= "<td>".(
+ ($packages{$spkg})
+ ? qq(<a href="http://packages.qa.debian.org/$spkg">$spkg</a>)
+ : qq($spkg)
+ )."</td>\n";
+
+ $text .= "<td".(
+ (! $packages{$spkg} or $pkgd->{chl_ver} ne $packages{$spkg})
+ ? ' class="upload">'
+ : '>');
+ $text .= qq(<a href="http://svn.debian.org/wsvn/pkg-perl/trunk/$_/debian/changelog?op=file&rev=0&sc=0" title=") . $pkgd->{chl_changer} . "\n" . $pkgd->{chl_date} . "\">" .$pkgd->{chl_ver} . "</a></td>\n";
+
+ my $archive_text = join(
+ "\n",
+ $packages{$spkg}||(),
+ (
+ ($incoming{$spkg})
+ ? "Incoming: $incoming{$spkg}"
+ : ()
+ ),
+ (
+ ($new{$spkg})
+ ? "NEW: $new{$spkg}"
+ : ()
+ ),
+ (
+ ($experimental{$spkg})
+ ? "experimental: $experimental{$spkg}"
+ : ()
+ ),
+ (
+ ($stable{$spkg} and not $packages{$spkg} and not $experimental{$spkg})
+ ? "stable: $stable{$spkg}"
+ : ()
+ ),
+ (
+ ($oldstable{$spkg} and not $stable{$spkg} and not $packages{$spkg} and not $experimental{$spkg})
+ ? "oldstable: $oldstable{$spkg}"
+ : ()
+ ),
+ );
+
+ $archive_text = qq(<a href="http://packages.qa.debian.org/$spkg">$archive_text</a>) if $packages{$spkg} or $experimental{$spkg} or $stable{$spkg} or $oldstable{$spkg};
+
+ $text .= "<td>$archive_text</td>\n";
+
+ my $bug_text = qq(<a href="http://bugs.debian.org/src:$spkg">$bugs{$spkg}</a>);
+
+ $text .= (
+ $bugs{$spkg} > 0
+ ? qq(<td class="bugs">$bug_text</td>\n)
+ : "<td></td>\n"
+ );
+
+ my $upstream_text = (
+ $pkgd->{watch_cpan} ? "CPAN: " : "") . $pkgd->{watch_ver};
+ $upstream_text = qq(<a href=") . $pkgd->{watch_url} . qq(">$upstream_text</a>) if $pkgd->{watch_url};
+
+ $text .= (
+ ($pkgd->{watch_unmangled_ver} ne $pkgd->{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;
+
+unlink $lockfile or die $!;
+
+# vim: et:sts=4:ai:sw=4
Propchange: scripts/qa/versioncheck3.pl
------------------------------------------------------------------------------
svn:executable = *
More information about the Pkg-perl-cvs-commits
mailing list