r5926 - /scripts/qa/versioncheck.pl
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Fri Jul 20 13:22:34 UTC 2007
Author: dmn
Date: Fri Jul 20 13:22:34 2007
New Revision: 5926
URL: http://svn.debian.org/wsvn/?sc=1&rev=5926
Log:
Almost works. Onlt the uscan checks remain
Modified:
scripts/qa/versioncheck.pl
Modified: scripts/qa/versioncheck.pl
URL: http://svn.debian.org/wsvn/scripts/qa/versioncheck.pl?rev=5926&op=diff
==============================================================================
--- scripts/qa/versioncheck.pl (original)
+++ scripts/qa/versioncheck.pl Fri Jul 20 13:22:34 2007
@@ -20,10 +20,30 @@
use SVN::Core;
use IO::Scalar;
#use Parse::CPAN::Packages;
+use Parse::DebianChangelog;
use CPAN ();
+use Getopt::Long;
+
+our $opt_debug = 0;
+
+GetOptions(
+ 'debug!' => \$opt_debug,
+);
+
+sub debugmsg(@)
+{
+ warn @_ if $opt_debug;
+};
# Get some information globally
+
+require Storable;
+require LWP::UserAgent;
+
+debugmsg( "CPAN mirror is $CPAN_MIRROR\n" );
+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) )
@@ -35,10 +55,12 @@
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) )
+ my $src_io = IO::Scalar->new(\$sources);
+
+ my $pkg;
+ while( <$src_io> )
{
+ chomp;
if( s/^Package: // )
{
$pkg = $_;
@@ -51,18 +73,23 @@
}
}
}
+
+debugmsg( sprintf("Information about %d packages loaded\n", scalar(keys(%packages))) );
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 ) )
+ my $inc_io = IO::Scalar->new(\$incoming);
+ while( <$inc_io> )
{
+ chomp;
next unless /a href="([^_]+)_(.+)\.dsc"/;
$incoming{$1} = $2;
}
};
+debugmsg( sprintf("Information about %d incoming packages loaded\n", scalar(keys(%incoming))) );
my %new; # contains {package => version} pairs
do {
@@ -86,6 +113,7 @@
}
}
};
+debugmsg( sprintf("Information about %d NEW packages loaded\n", scalar(keys(%new))) );
my $cpan; # instance of Parse::CPAN::Packages
do {
@@ -156,79 +184,136 @@
# loop over packages
for my $section qw(packages tools)
{
- my $svn_packages = $svn->ls("$SVN_REPO/$section/", 'HEAD', 0);
+ my $svn_packages = $svn->ls("$SVN_REPO/$section", 'HEAD', 0);
+
+ debugmsg(
+ sprintf(
+ "%d entries in section %s\n",
+ scalar(keys(%$svn_packages)),
+ $section,
+ ),
+ );
foreach my $pkg( keys %$svn_packages )
{
next if $pkg eq 'attic';
- my $in_archive = $packages{$pkg};
+ debugmsg( "Examining $pkg\n" );
+
+ my $in_archive = $packages{$pkg} || '';
+
+ debugmsg( sprintf(" - Archive has %s\n", $in_archive||'none') );
my $changelog;
my $changelog_fh = IO::Scalar->new( \$changelog );
- $svn->cat(
- $changelog_fh,
- "$SVN_REPO/$section/$pkg/trunk/debian/changelog",
- 'HEAD',
+ my $in_svn = 'Unknown SVN version';
+ eval {
+ $svn->cat(
+ $changelog_fh,
+ "$SVN_REPO/$section/$pkg/trunk/debian/changelog",
+ 'HEAD',
+ );
+ my $cl = Parse::DebianChangelog->init({instring=>$changelog});
+ my @cl = $cl->data;
+ foreach( @cl )
+ {
+ next unless $_->Distribution eq 'unstable';
+ next if $_->Changes =~ /NOT RELEASED/;
+
+ $in_svn = $_->Version;
+ last;
+ }
+ };
+ if($@)
+ {
+ if( $@ =~ /^Filesystem has no item: / )
+ {
+ $in_svn = 'Missing debian/changelog';
+ }
+ else
+ {
+ die $@;
+ }
+ }
+ my $up_svn = $in_svn;
+ $up_svn =~ s/^(?:\d+:)?(.+?)(?:-[^-]+)?$/$1/ if $up_svn;
+ debugmsg(
+ sprintf(
+ " - SVN has %s (upstream version=%s)\n",
+ $in_svn||'none',
+ $up_svn||'none',
+ )
);
- 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};
+ debugmsg( sprintf( " - incoming has %s\n", $in_incoming||'none' ) );
my $in_new = $new{$pkg};
+ debugmsg( sprintf( " - NEW has %s\n", $in_new||'none' ) );
my $mod_name = $pkg;
+ $mod_name =~ s/-perl$//;
$mod_name =~ s/^lib(.)/\U$1/;
$mod_name =~ s/-(.)/::\U$1/g;
- $mod_name =~ s/-perl$//;
-
- my $mod_cpan = $cpan->Expand('Module', $mod_name);
+ debugmsg( sprintf( " + module name is %s\n", $mod_name ) );
+
+ 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/;
+ debugmsg( sprintf( " - CPAN has %s\n", $in_cpan||'none' ) );
my $upstream = '';
- if( @watch )
- {
- $upstream = latest_upstream_from_watch(@watch);
- }
- else
- {
- $upstream = (
- ( $in_svn =~ /-.+$/ )
- ? latest_upstream_from_watch(@watch)
- : $in_svn # native package
+ eval {
+ my $watch;
+ my $watch_io = IO::Scalar->new(\$watch);
+ $svn->cat(
+ $watch_io,
+ "$SVN_REPO/$section/$pkg/trunk/debian/watch",
+ 'HEAD',
);
- }
-
- if( $up_svn ne $upstream
+
+ my @watch = grep( /^(http|ftp)/, split(/\n/, $watch) ) if $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/!;
+ }
+
+ if( @watch )
+ {
+ $upstream = latest_upstream_from_watch(@watch);
+ }
+ else
+ {
+ $upstream = (
+ ( $in_svn =~ /-.+$/ )
+ ? 'Invalid debian/watch'
+ : $in_svn # native package
+ );
+ }
+ };
+ if($@)
+ {
+ if( $@ =~ /^Filesystem has no item: / )
+ {
+ $upstream = 'Missing debian/watch';
+ }
+ else
+ {
+ die $@;
+ }
+ }
+ debugmsg( sprintf( " - upstream has %s\n", $upstream||'none' ) );
+
+
+ if( $up_svn ne $upstream
or
$in_svn ne $in_archive
and
@@ -243,7 +328,7 @@
($in_svn ne $in_archive)
? ' class="upload"'
: ''
- ).$in_svn."</td>\n";
+ ).">$in_svn</td>\n";
print "<td>".join(
"\n",
$in_archive,
More information about the Pkg-perl-cvs-commits
mailing list