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&amp;rev=0&amp;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&amp;rev=0&amp;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&amp;rev=0&amp;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:&nbsp;$incoming{$spkg}"
+            : ()
+        ),
+        (
+            ($new{$spkg})
+            ? "NEW:&nbsp;$new{$spkg}"
+            : ()
+        ),
+        (
+            ($experimental{$spkg})
+            ? "experimental:&nbsp;$experimental{$spkg}"
+            : ()
+        ),
+        (
+            ($stable{$spkg} and not $packages{$spkg} and not $experimental{$spkg})
+            ? "stable:&nbsp;$stable{$spkg}"
+            : ()
+        ),
+        (
+            ($oldstable{$spkg} and not $stable{$spkg} and not $packages{$spkg} and not $experimental{$spkg})
+            ? "oldstable:&nbsp;$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:&nbsp;" : "") . $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