r5987 - /scripts/qa/versioncheck.pl
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Thu Jul 26 13:51:40 UTC 2007
Author: dmn
Date: Thu Jul 26 13:51:40 2007
New Revision: 5987
URL: http://svn.debian.org/wsvn/?sc=1&rev=5987
Log:
Allow generating status for single package (not quite useful yet); Apply some magic to try to guess CPAN module name from the package name and watch file
Modified:
scripts/qa/versioncheck.pl
Modified: scripts/qa/versioncheck.pl
URL: http://svn.debian.org/wsvn/scripts/qa/versioncheck.pl?rev=5987&op=diff
==============================================================================
--- scripts/qa/versioncheck.pl (original)
+++ scripts/qa/versioncheck.pl Thu Jul 26 13:51:40 2007
@@ -212,9 +212,9 @@
return $cpan_ver || 'EUNIMPL';
}
-sub latest_upstream_from_cpan($)
-{
- my ($watch) = @_;
+sub latest_upstream_from_cpan($$)
+{
+ my ($watch, $pkg) = @_;
my @cpan = grep( m{^(?:http|ftp)://.*cpan}i, @$watch );
@@ -235,9 +235,32 @@
{
push @vers, $cpan_mod->cpan_version;
}
- elsif( ! /^Net::/ )
- {
- $cpan_mod = $cpan->expand('Module', "Net::$_");
+# elsif( ! /^Net::/ )
+# {
+# $cpan_mod = $cpan->expand('Module', "Net::$_");
+# push @vers, $cpan_mod->cpan_version if $cpan_mod;
+# }
+ else
+ {
+ # Try to gyess real module name given the distribution file
+ # name (without version) and the perl package name
+ my $tmp = $pkg;
+ $tmp =~ s/^lib//; $tmp =~ s/-perl$//;
+ my @pkg_parts = split(/-/, $tmp);
+
+ my @mod_parts;
+ my $watch_mod = $_;
+ while( @pkg_parts and $watch_mod =~ s/^($pkg_parts[0])//xi )
+ {
+ push @mod_parts, $1;
+ shift @pkg_parts;
+ }
+
+ return undef if @pkg_parts;
+
+ my $mod_name = join( '::', @mod_parts );
+ debugmsg( sprintf( " cpan search %s\n", $mod_name ) );
+ $cpan_mod = $cpan->expand( 'Module', $mod_name );
push @vers, $cpan_mod->cpan_version if $cpan_mod;
}
}
@@ -295,208 +318,229 @@
my $total_shown = 0;
my $svn = SVN::Client->new();
-# loop over packages
-for my $section qw(packages tools)
-{
- my $svn_packages = $svn->ls("$SVN_REPO/$section", 'HEAD', 0);
-
+sub check_package($$)
+{
+ my( $pkg, $section ) = @_;
+
+ debugmsg( "Examining $pkg\n" );
+
+ my $in_archive = $packages{$pkg} || '';
+ debugmsg( sprintf(" - Archive has %s\n", $in_archive||'none') );
+
+ my $in_experimental = $experimental{$pkg};
+ debugmsg( sprintf( " - experimental has %s\n", $in_experimental||'none' ) );
+
+ my $in_stable = $stable{$pkg};
+ debugmsg( sprintf( " - stable has %s\n", $in_stable||'none' ) );
+
+ my $in_oldstable = $oldstable{$pkg};
+ debugmsg( sprintf( " - oldstable has %s\n", $in_oldstable||'none' ) );
+
+
+ my $changelog;
+ my $changelog_fh = IO::Scalar->new( \$changelog );
+
+ 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(
- "%d entries in section %s\n",
- scalar(keys(%$svn_packages)),
- $section,
- ),
+ " - SVN has %s (upstream version=%s)\n",
+ $in_svn||'none',
+ $up_svn||'none',
+ )
);
- foreach my $pkg( sort(keys %$svn_packages) )
- {
- next if $pkg eq 'attic';
-
+
+ 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 $upstream = '';
+ my $in_cpan = '';
+
+ eval {
+ my $watch;
+ my $watch_io = IO::Scalar->new(\$watch);
+ $svn->cat(
+ $watch_io,
+ "$SVN_REPO/$section/$pkg/trunk/debian/watch",
+ 'HEAD',
+ );
+
+ 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 )
+ {
+ $in_cpan = latest_upstream_from_cpan(\@watch, $pkg);
+ debugmsg( sprintf( " - CPAN has %s\n", $in_cpan||'none' ) );
+ $upstream = latest_upstream_from_watch(\@watch, $in_cpan, $up_svn);
+ debugmsg( sprintf( " - upstream has %s\n", $upstream||'none' ) );
+ }
+ else
+ {
+ $upstream = (
+ ( $in_svn =~ /-.+$/ )
+ ? 'Invalid debian/watch'
+ : $in_svn # native package
+ );
+ }
+ };
+ if($@)
+ {
+ if( $@ =~ /^Filesystem has no item: / )
+ {
+ $upstream = (
+ ( $in_svn =~ /-.+$/ )
+ ? 'Missing debian/watch'
+ : $in_svn # native package
+ );
+ }
+ else
+ {
+ die $@;
+ }
+ }
+
+
+ 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";
+
+ my $archive_text = join(
+ "\n",
+ $in_archive||' ',
+ (
+ ($in_incoming)
+ ? "Incoming: $in_incoming"
+ : ()
+ ),
+ (
+ ($in_new)
+ ? "NEW: $in_new"
+ : ()
+ ),
+ (
+ ($in_experimental)
+ ? "experimental: $in_experimental"
+ : ()
+ ),
+ (
+ ($in_stable and not $in_archive and not $in_experimental)
+ ? "stable: $in_stable"
+ : ()
+ ),
+ (
+ ($in_oldstable and not $in_stable and not $in_archive and not $in_experimental)
+ ? "oldstable: $in_oldstable"
+ : ()
+ ),
+ );
+
+ $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(
+ "\n",
+ $upstream,
+ ( $in_cpan ? "CPAN: $in_cpan" : () )
+ )."</td>\n"
+ : "<td> </td>\n"
+ );
+ print "</tr>\n";
+
+ return 1;
+ }
+
+ return 0;
+}
+
+if( @ARGV )
+{
+ foreach my $pkg( @ARGV )
+ {
$total++;
- debugmsg( "Examining $pkg\n" );
-
- my $in_archive = $packages{$pkg} || '';
- debugmsg( sprintf(" - Archive has %s\n", $in_archive||'none') );
-
- my $in_experimental = $experimental{$pkg};
- debugmsg( sprintf( " - experimental has %s\n", $in_experimental||'none' ) );
-
- my $in_stable = $stable{$pkg};
- debugmsg( sprintf( " - stable has %s\n", $in_stable||'none' ) );
-
- my $in_oldstable = $oldstable{$pkg};
- debugmsg( sprintf( " - oldstable has %s\n", $in_oldstable||'none' ) );
-
-
- my $changelog;
- my $changelog_fh = IO::Scalar->new( \$changelog );
-
- 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;
+ $total_shown++ if check_package($pkg, 'packages');
+ }
+}
+else
+{
+# loop over packages
+ for my $section qw(packages tools)
+ {
+ my $svn_packages = $svn->ls("$SVN_REPO/$section", 'HEAD', 0);
+
debugmsg(
sprintf(
- " - SVN has %s (upstream version=%s)\n",
- $in_svn||'none',
- $up_svn||'none',
- )
+ "%d entries in section %s\n",
+ scalar(keys(%$svn_packages)),
+ $section,
+ ),
);
-
- 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 $upstream = '';
- my $in_cpan = '';
-
- eval {
- my $watch;
- my $watch_io = IO::Scalar->new(\$watch);
- $svn->cat(
- $watch_io,
- "$SVN_REPO/$section/$pkg/trunk/debian/watch",
- 'HEAD',
- );
-
- 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 )
- {
- $in_cpan = latest_upstream_from_cpan(\@watch);
- debugmsg( sprintf( " - CPAN has %s\n", $in_cpan||'none' ) );
- $upstream = latest_upstream_from_watch(\@watch, $in_cpan, $up_svn);
- debugmsg( sprintf( " - upstream has %s\n", $upstream||'none' ) );
- }
- else
- {
- $upstream = (
- ( $in_svn =~ /-.+$/ )
- ? 'Invalid debian/watch'
- : $in_svn # native package
- );
- }
- };
- if($@)
- {
- if( $@ =~ /^Filesystem has no item: / )
- {
- $upstream = (
- ( $in_svn =~ /-.+$/ )
- ? 'Missing debian/watch'
- : $in_svn # native package
- );
- }
- else
- {
- die $@;
- }
- }
-
-
- 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";
-
- my $archive_text = join(
- "\n",
- $in_archive||' ',
- (
- ($in_incoming)
- ? "Incoming: $in_incoming"
- : ()
- ),
- (
- ($in_new)
- ? "NEW: $in_new"
- : ()
- ),
- (
- ($in_experimental)
- ? "experimental: $in_experimental"
- : ()
- ),
- (
- ($in_stable and not $in_archive and not $in_experimental)
- ? "stable: $in_stable"
- : ()
- ),
- (
- ($in_oldstable and not $in_stable and not $in_archive and not $in_experimental)
- ? "oldstable: $in_oldstable"
- : ()
- ),
- );
-
- $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(
- "\n",
- $upstream,
- ( $in_cpan ? "CPAN: $in_cpan" : () )
- )."</td>\n"
- : "<td> </td>\n"
- );
- print "</tr>\n";
-
- $total_shown++;
+ foreach my $pkg( sort(keys %$svn_packages) )
+ {
+ next if $pkg eq 'attic';
+
+ $total++;
+
+ $total_shown++ if check_package($pkg, $section);
}
}
}
More information about the Pkg-perl-cvs-commits
mailing list