r5985 - /scripts/qa/versioncheck.pl

[dmn at users.alioth.debian.org]

Author: dmn
Date: Thu Jul 26 10:36:59 2007
New Revision: 5985

URL: http://svn.debian.org/wsvn/?sc=1&rev=5985
Log:
Make archive version link to the PTS and add BTS link. Add support to experimental. Show also coult of all group packages

Modified:
    scripts/qa/versioncheck.pl

Modified: scripts/qa/versioncheck.pl
URL: http://svn.debian.org/wsvn/scripts/qa/versioncheck.pl?rev=5985&op=diff
==============================================================================
--- scripts/qa/versioncheck.pl (original)
+++ scripts/qa/versioncheck.pl Thu Jul 26 10:36:59 2007
@@ -14,9 +14,6 @@
 # so 0.2200 (cpan) gets equal to 0.22 (debian) when this is described
 #
 # Add support for checking list of packages, given on the command line
-#
-# Also look in experimental. Do not consider it sufficient, i.e. still show the
-# package even if upstream version matches experimental.
 
 our $THIS_REVISION = '$Id$';
 
@@ -60,18 +57,19 @@
 debugmsg( "HOME=$ENV{HOME}\n" );
 debugmsg( "CPAN home=".$CPAN::Config->{cpan_home}."\n" );
 
-my %packages;   # contains {package => version} pairs
-foreach my $section ( qw(main contrib non-free) )
-{
+sub scan_packages($$$)
+{
+    my( $suite, $section, $hash ) = @_;
     # 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/unstable/$section/source/Sources.gz";
+    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);
 
+    local($_);
     my $pkg;
     while( <$src_io> )
     {
@@ -84,12 +82,25 @@
 
         if( s/^Version: // )
         {
-            $packages{$pkg} = $_;
+            $hash->{$pkg} = $_;
         }
     }
 }
 
+my %packages;   # contains {package => version} pairs
+scan_packages(
+    'unstable', $_, \%packages,
+) foreach( qw(main contrib non-free) );
+
 debugmsg( sprintf("Information about %d packages loaded\n", scalar(keys(%packages))) );
+
+my %experimental;   # contains {package => version} pairs
+scan_packages(
+    'experimental', $_, \%experimental,
+) foreach( qw( main contrib non-free) );
+
+debugmsg( sprintf("Information about %d experimental packages loaded\n", scalar(keys(%experimental))) );
+
 
 my %incoming;   # contains {package => version} pairs
 do {
@@ -265,6 +276,7 @@
 _EOF
 
 my $total = 0;
+my $total_shown = 0;
 my $svn = SVN::Client->new();
 
 # loop over packages
@@ -280,9 +292,11 @@
         ),
     );
 
-    foreach my $pkg( keys %$svn_packages )
+    foreach my $pkg( sort(keys %$svn_packages) )
     {
         next if $pkg eq 'attic';
+
+        $total++;
 
         debugmsg( "Examining $pkg\n" );
 
@@ -337,6 +351,8 @@
         debugmsg( sprintf( " - incoming has %s\n", $in_incoming||'none' ) );
         my $in_new = $new{$pkg}||'';
         debugmsg( sprintf( " - NEW has %s\n", $in_new||'none' ) );
+        my $in_experimental = $experimental{$pkg};
+        debugmsg( sprintf( " - experimental has %s\n", $in_experimental||'none' ) );
 
         my $upstream = '';
         my $in_cpan = '';
@@ -412,7 +428,8 @@
                 ? ' class="upload"'
                 : ''
             ).">$in_svn</td>\n";
-            print "<td>".join(
+
+            my $archive_text = join(
                 "\n",
                 $in_archive||'&nbsp;',
                 (
@@ -425,7 +442,16 @@
                     ? "NEW:&nbsp;$in_new"
                     : ()
                 ),
-            )."</td>\n";
+                (
+                    ($in_experimental)
+                    ? "experimental:&nbsp;$in_experimental"
+                    : ()
+                ),
+            );
+
+            $archive_text = qq(<a href="http://packages.qa.debian.org/$pkg">$archive_text</a> <a style="font-size:smaller" href="http://bugs.debian.org/src:$pkg">bts</a>) if $in_archive or $in_experimental;
+
+            print "<td>$archive_text</td>\n";
             print(
                 ($up_svn ne $upstream)
                 ? "<td class=\"upgrade\">".join(
@@ -437,14 +463,14 @@
             );
             print "</tr>\n";
 
-            $total++;
+            $total_shown++;
         }
     }
 }
 
 my $date = gmtime;
 print <<_EOF;
-<tr><td colspan=\"4\"><b>TOTAL: $total</b></td></tr>
+<tr><td colspan=\"4\"><b>TOTAL: $total_shown/$total</b></td></tr>
 </table>
 <hr>
 $date UTC<br>