r5919 - in /scripts/qa: Common.pm versioncheck.pl
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Fri Jul 20 09:27:49 UTC 2007
Author: dmn
Date: Fri Jul 20 09:27:49 2007
New Revision: 5919
URL: http://svn.debian.org/wsvn/?sc=1&rev=5919
Log:
Initial implementation of versioncheck in Perl
Added:
scripts/qa/Common.pm (with props)
scripts/qa/versioncheck.pl (with props)
Added: scripts/qa/Common.pm
URL: http://svn.debian.org/wsvn/scripts/qa/Common.pm?rev=5919&op=file
==============================================================================
--- scripts/qa/Common.pm (added)
+++ scripts/qa/Common.pm Fri Jul 20 09:27:49 2007
@@ -1,0 +1,54 @@
+# $Id$
+package Common;
+use strict;
+use Sys::Hostname;
+use base 'Exporter';
+
+our @EXPORT = qw(
+ $SVN_REPO
+ $MIRROR
+ $CPAN_MIRROR
+);
+
+our $REPO = "svn://svn.debian.org/svn/pkg-perl";
+our $MIRROR = "MIRROR=ftp://ftp.debian.org";
+our $CPAN_MIRROR = "ftp://cpan.org/pub/CPAN";
+
+# special hosts
+for( hostname )
+{
+ # alioth
+ /alioth/ && do {
+ $REPO = "file:///svn/pkg-perl";
+ $MIRROR = "ftp://ftp.nl.debian.org";
+ $CPAN_MIRROR = "ftp://cpan.wanadoo.nl/pub/CPAN";
+ last;
+ };
+
+ # Gregor
+ /belanna|nerys/ && do {
+ $MIRROR = "ftp://ftp.at.debian.org";
+ $CPAN_MIRROR = "ftp://gd.tuwien.ac.at/pub/CPAN";
+ last;
+ };
+
+ # dam
+ /pc1/ && do {
+ $MIRROR = "http://proxy:9999";
+ $CPAN_MIRROR = "ftp://ftp.uni-sofia.bg/cpan";
+ last;
+ };
+
+ die "Unknown host $_";
+}
+
+# This mirror is near alioth. From #alioth:
+# <ard> ard at c32791:~$ sudo /usr/sbin/traceroute -A cpan.wanadoo.nl|grep AS1200
+# <ard> traceroute to ftp.wanadoo.nl (194.134.17.10), 64 hops max, 40 byte packets
+# <ard> 5 ams-ix.euro.net (195.69.144.70) [AS1200] 1 ms 1 ms 1 ms
+# <ard> jups
+# <ard> 10G going to as1200
+# <ard> As long as it passes as1200 it's ok... Everything else is $$ :-(
+# CPAN=ftp://cpan.wanadoo.nl/pub/CPAN
+
+1;
Propchange: scripts/qa/Common.pm
------------------------------------------------------------------------------
svn:keywords = Id
Added: scripts/qa/versioncheck.pl
URL: http://svn.debian.org/wsvn/scripts/qa/versioncheck.pl?rev=5919&op=file
==============================================================================
--- scripts/qa/versioncheck.pl (added)
+++ scripts/qa/versioncheck.pl Fri Jul 20 09:27:49 2007
@@ -1,0 +1,280 @@
+#!/use/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
+
+our $THIS_REVISION = '$Id$';
+
+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::CPAN::Packages;
+
+
+# Get some information globally
+
+my %packages; # contains {package => version} pairs
+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/unstable/$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( $pkg );
+ foreach( split(/\n/, $sources) )
+ {
+ if( s/^Package: // )
+ {
+ $pkg = $_;
+ next;
+ }
+
+ if( s/^Version: // )
+ {
+ $packages{$pkg} = $_;
+ }
+ }
+}
+
+my %incoming; # contains {package => version} pairs
+do {
+ my $incoming = LWP::Simple::get('http://incoming.debian.org')
+ or die "Unable to retreive http://incoming.debian.org";
+ foreach( split(/\n/, $incoming ) )
+ {
+ next unless /a href="([^_]+)_(.+)\.dsc"/;
+
+ $incoming{$1} = $2;
+ }
+};
+
+my %new; # contains {package => version} pairs
+do {
+ 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)
+ ],
+ );
+ 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;
+
+ $new{$row->[0]} = $versions[-1];# use the last uploaded version
+ }
+ }
+};
+
+my $cpan = Parse::CPAN::Packages->new(
+ Compress::Zlib->memGunzip(
+ LWP::Simple::get("$CPAN_MIRROR/modules/02packages.details.txt.gz",
+ ),
+ ),
+);
+
+sub latest_upstream_from_watch(@)
+{
+ my @watch = @_;
+
+ return 'EUNIMPL';
+}
+
+print <<_EOF;
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
+ "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+ <title>pkg-perl TODO</title>
+ <style type="text/css">
+ body {
+ background: white;
+ color: black;
+ }
+ table {
+ border: 1px solid black;
+ border-collapse: collapse;
+ }
+ 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 $pool = SVN::Pool->new_default;
+my $svn = SVN::Client->new();
+
+# loop over packages
+for my $section qw(packages tools)
+{
+ my $svn_packages = $svn->ls("$SVN_REPO/$section/");
+
+ foreach my $pkg( keys %$svn_packages )
+ {
+ next if $pkg eq 'attic';
+
+ my $in_archive = $packages{$pkg};
+
+ my $changelog;
+ my $changelog_fh = IO::Scalar->new( \$changelog );
+
+ $svn->cat(
+ $changelog_fh,
+ "$SVN_REPO/$section/$pkg/trunk/debian/changelog",
+ 'HEAD',
+ );
+ my $cl = Parse::DebianChangelog->new({instring=>$changelog});
+ my @cl = $cl->data;
+ my $in_svn = 'Unknown SVN version';
+ foreach( @cl )
+ {
+ next unless $_->Distribution eq 'unstable';
+ next if $_->Changes =~ /NOT RELEASED/;
+
+ $in_svn = $_->Version;
+ last;
+ }
+
+ my $in_incoming = $incoming{$pkg};
+ my $in_new = $new{$pkg};
+
+ my $mod_name = $pkg;
+ $mod_name =~ s/^lib(.)/\U$1/;
+ $mod_name =~ s/-(.)/::\U$1/g;
+ $mod_name =~ s/-perl$//;
+
+ my $mod_cpan = $cpan->Expand('Module', $mod_name);
+ my $in_cpan = $mod_cpan->cpan_version if $mod_cpan;
+
+
+ my $watch = $svn->cat("$SVN_REPO/$section/$pkg/trunk/debian/watch", 'HEAD') if $svn->ls("$SVN_REPO/$section/$pkg/trunk/debian/watch", 'HEAD', 0);
+
+ my @watch = grep( /^(http|ftp)/, split(/\n/, $watch) );
+
+ @watch = grep( /^(http|ftp)/, @watch );
+
+ foreach(@watch)
+ {
+ s!^http://www.cpan.org/!$CPAN_MIRROR/!;
+ s!^ftp://www.cpan.org/!$CPAN_MIRROR/!;
+ s!^http://backpan.perl.org/authors/!$CPAN_MIRROR/modules/by-author/!;
+ s!^http://mirrors.kernel.org/cpan/!$CPAN_MIRROR/!;
+ s!^ftp://mirrors.kernel.org/cpan/!$CPAN_MIRROR/!;
+ }
+
+ my $up_svn = $in_svn =~ s/^(?:\d+:)?(.+?)(?:-[^-]+)?$/$1/;
+
+ my $upstream = '';
+
+ if( @watch )
+ {
+ $upstream = latest_upstream_from_watch(@watch);
+ }
+ else
+ {
+ $upstream = (
+ ( $in_svn =~ /-.+$/ )
+ ? latest_upstream_from_watch(@watch)
+ : $in_svn # native package
+ );
+ }
+
+ if( $up_svn ne $upstream
+ or
+ $in_svn ne $in_archive
+ and
+ $in_svn ne $in_incoming
+ and
+ $in_svn ne $in_new
+ )
+ {
+ print "<tr>\n";
+ print "<td>$pkg</td>\n";
+ print "<td".(
+ ($in_svn ne $in_archive)
+ ? ' class="upload"'
+ : ''
+ ).$in_svn."</td>\n";
+ print "<td>".join(
+ "\n",
+ $in_archive,
+ (
+ ($in_incoming)
+ ? "Incoming: $in_incoming"
+ : ()
+ ),
+ (
+ ($in_new)
+ ? "NEW: $in_new"
+ : ()
+ ),
+ )."</td>\n";
+ print(
+ ($up_svn ne $upstream)
+ ? "<td class=\"upgrade\">$upstream</td>\n"
+ : "<td> </td>\n"
+ );
+ print "<tr>\n";
+
+ $total++;
+ }
+ }
+}
+
+my $date = time;
+print <<_EOF;
+<tr><td colspan=\"4\"><b>TOTAL: $total</b></td></tr>
+</table>
+<hr>
+$date<br>
+<i>$THIS_REVISION</i>
+</body>
+_EOF
+
+
+exit 0
+
+# vim: et:sts=4:ai
Propchange: scripts/qa/versioncheck.pl
------------------------------------------------------------------------------
svn:keywords = Id
More information about the Pkg-perl-cvs-commits
mailing list