r6169 - /scripts/qa/versioncheck.pl
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Tue Jul 31 09:21:43 UTC 2007
Author: dmn
Date: Tue Jul 31 09:21:43 2007
New Revision: 6169
URL: http://svn.debian.org/wsvn/?sc=1&rev=6169
Log:
Re-organization of different versions parsing order; Support version mangling from watch file
Modified:
scripts/qa/versioncheck.pl
Modified: scripts/qa/versioncheck.pl
URL: http://svn.debian.org/wsvn/scripts/qa/versioncheck.pl?rev=6169&op=diff
==============================================================================
--- scripts/qa/versioncheck.pl (original)
+++ scripts/qa/versioncheck.pl Tue Jul 31 09:21:43 2007
@@ -279,11 +279,46 @@
return $cpan_ver || 'EUNIMPL';
}
+sub cpan_versions($$$)
+{
+ my($where, $wline, $opts) = @_;
+
+ $wline =~ s{(.+)/\s?([^/\s]+)(?:\s|$)}{};
+ my( $key, $filter) = ($1, $2);
+ debugmsg( sprintf( " module search %s %s\n", $key, $filter ) );
+
+ my $list = $where->{$key};
+ unless($list)
+ {
+ debugmsg("directory $key not found\n");
+ return();
+ }
+
+ my @vers;
+ foreach(@$list)
+ {
+ debugmsg(" looking at $_\n") if 0;
+ if( my $uvms = $opts->{uversionmangle} )
+ {
+ my @uvms = split(/;/, $uvms);
+
+ foreach my $uvm( @uvms )
+ {
+ eval "\$_ =~ $uvm";
+ die "<<\$_ =~ $uvm>> $@" if $@;
+ }
+ }
+ push @vers, $1 if $_ =~ $filter;
+ }
+
+ return @vers;
+}
+
sub latest_upstream_from_cpan($$)
{
my ($watch, $pkg) = @_;
- my @cpan = grep( m{^(?:http|ftp)://.*cpan}i, @$watch );
+ my @cpan = grep( $_->[0] =~ m{(?:^|\s)(?:http|ftp)://\S*cpan}i, @$watch );
return undef unless @cpan;
@@ -291,53 +326,23 @@
foreach(@cpan)
{
- if( s{^(?:http|ftp)://.*cpan.*/modules/by-module/}{}i )
+ my( $wline, $opts ) = @$_;
+ if( $wline =~ s{^(?:http|ftp)://\S*cpan\S*/modules/by-module/}{}i )
{
# lookup by module
-
- s{(.+)/\s?([^/\s]+)(?:\s|$)}{};
- my( $key, $filter) = ($1, $2);
- debugmsg( sprintf( " module search %s %s\n", $key, $filter ) );
-
- my $list = $cpan_modules{$key};
- unless($list)
- {
- debugmsg("directory $key not found\n");
- return undef;
- }
-
- foreach(@$list)
- {
- debugmsg(" looking at $_\n");
- push @vers, $1 if $_ =~ $filter;
- }
- }
- elsif( s{^(?:http|ftp)://.*cpan.*/authors/by-id/}{}i
+ push @vers, cpan_versions(\%cpan_modules, $wline, $opts);
+ }
+ elsif( $wline =~ s{^(?:http|ftp)://\S*cpan\S*/authors/(?:by-)?id/}{}i
or
- s{^(?:http|ftp)://.*cpan.*/(?:by-)?authors/id/}{}i
+ $wline =~ s{^(?:http|ftp)://\S*cpan\S*/(?:by-)?authors/id/}{}i
)
{
# lookup by author
-
- s{(.+)/\s?([^/\s]+)(?:\s|$)}{};
- my( $key, $filter) = ($1, $2);
- debugmsg( sprintf( " author search %s %s\n", $key, $filter ) );
-
- my $list = $cpan_authors{$key};
- unless($list)
- {
- debugmsg("directory $key not found\n");
- return undef;
- }
-
- foreach(@$list)
- {
- push @vers, $1 if /$filter/;
- }
+ push @vers, cpan_versions(\%cpan_authors, $wline, $opts);
}
else
{
- debugmsg( sprintf( " can't determine typo of search for %s\n", $_ ) );
+ debugmsg( sprintf( " can't determine type of search for %s\n", $wline ) );
return undef;
}
}
@@ -345,6 +350,24 @@
@vers = sort { cmp_ver($a,$b) } @vers;
return $vers[-1] || '';
+}
+
+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;
}
@@ -414,7 +437,6 @@
my $in_oldstable = $oldstable{$pkg};
debugmsg( sprintf( " - oldstable has %s\n", $in_oldstable||'none' ) );
-
my $changelog;
my $changelog_fh = IO::Scalar->new( \$changelog );
@@ -450,25 +472,11 @@
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 $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 = '';
-
+ my @watch;
eval {
my $watch;
my $watch_io = IO::Scalar->new(\$watch);
@@ -478,33 +486,40 @@
'HEAD',
);
- my @watch = grep( /^(http|ftp)/, split(/\n/, $watch) ) if $watch;
-
- @watch = grep( /^(http|ftp)/, @watch );
-
- foreach(@watch)
- {
+ $watch =~ s/\\\n//gs;
+ my @watch_lines = split(/\n/, $watch) if $watch;
+
+ @watch_lines = grep( !/^#/, @watch_lines );
+
+ foreach(@watch_lines)
+ {
+ # 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!!;
+ # 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)$/;
+
+ /([^=]+)=(.*)/;
+ 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/!;
- }
-
- 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
- );
+
+ push @watch, [ $_, \%opts ];
}
};
if($@)
@@ -522,6 +537,40 @@
die $@;
}
}
+
+ my $up_svn = $in_svn;
+ $up_svn =~ s/^(?:\d+:)?(.+?)(?:-[^-]+)?$/$1/ if $up_svn;
+ $up_svn = unmangle_debian_version($up_svn, \@watch) if @watch;
+ debugmsg(
+ sprintf(
+ " - SVN has %s (upstream version=%s)\n",
+ $in_svn||'none',
+ $up_svn||'none',
+ )
+ );
+
+ 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
+ );
+ }
+
+
+ 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' ) );
+
if( $up_svn ne $upstream
More information about the Pkg-perl-cvs-commits
mailing list