r6097 - /scripts/qa/versioncheck.pl

[dmn at users.alioth.debian.org]

Author: dmn
Date: Mon Jul 30 12:20:12 2007
New Revision: 6097

URL: http://svn.debian.org/wsvn/?sc=1&rev=6097
Log:
More power to the hands; package information is cached (experimental, unstable, stable, oldstable) with expiration; use the ls-lR file from CPAN mirror, also cached

Modified:
    scripts/qa/versioncheck.pl

Modified: scripts/qa/versioncheck.pl
URL: http://svn.debian.org/wsvn/scripts/qa/versioncheck.pl?rev=6097&op=diff
==============================================================================
--- scripts/qa/versioncheck.pl (original)
+++ scripts/qa/versioncheck.pl Mon Jul 30 12:20:12 2007
@@ -56,12 +56,41 @@
 
 # Get some information globally
 
-require Storable;
-require LWP::UserAgent;
+use Storable();
+use LWP::UserAgent;
 
 debugmsg( "CPAN mirror is $CPAN_MIRROR\n" );
 debugmsg( "HOME=$ENV{HOME}\n" );
 debugmsg( "CPAN home=".$CPAN::Config->{cpan_home}."\n" );
+
+sub from_cache($$$)
+{
+    my( $ref, $name, $max_age) = @_;
+
+    my $dir = $ENV{HOME}.'/.dpg/versioncheck';
+
+    return undef unless -f "$dir/$name" and -M(_) <= $max_age/24;
+
+    my $data = Storable::retrieve("$dir/$name");
+    return undef unless $data;
+
+    debugmsg("$name loaded from cache (".scalar(keys(%$data)).")\n");
+
+    %$ref = %$data;
+    return 1;
+}
+
+sub to_cache($$)
+{
+    my( $ref, $name) = @_;
+
+    my $home = $ENV{HOME};
+
+    -d "$home/.dpg" or mkdir("$home/.dpg") or die $!;
+    -d "$home/.dpg/versioncheck" or mkdir("$home/.dpg/versioncheck") or die $!;
+
+    Storable::store($ref, "$home/.dpg/versioncheck/$name");
+}
 
 sub scan_packages($$)
 {
@@ -101,27 +130,28 @@
             $suite,
         ),
     );
+    to_cache($hash, $suite);
 }
 
 my %packages;   # contains {package => version} pairs
 scan_packages(
     'unstable', \%packages,
-);
+) unless from_cache(\%packages, 'unstable', 6);
 
 my %experimental;   # contains {package => version} pairs
 scan_packages(
     'experimental', \%experimental,
-);
+) unless from_cache(\%experimental, 'experimental', 6);
 
 my %stable;   # contains {package => version} pairs
 scan_packages(
     'stable', \%stable,
-);
+) unless from_cache(\%stable, 'stable', 168);   # 1 week
 
 my %oldstable;   # contains {package => version} pairs
 scan_packages(
     'oldstable', \%oldstable,
-);
+) unless from_cache(\%oldstable, 'oldstable', 168); # 1 week
 
 
 my %incoming;   # contains {package => version} pairs
@@ -163,6 +193,51 @@
 };
 debugmsg( sprintf("Information about %d NEW packages loaded\n", scalar(keys(%new))) );
 
+my %cpan_authors;
+my %cpan_modules;
+do {
+    use IO::Uncompress::Gunzip;
+    my $storage;
+    my $lslr = LWP::Simple::get("$CPAN_MIRROR/ls-lR.gz");
+    my $io = IO::Uncompress::Gunzip->new(\$lslr);
+
+    my ($section, $path);
+    while( <$io> )
+    {
+        chomp;
+        next unless $_;
+
+        if( m{^\./authors/id/(.+):} )
+        {
+            $storage = $cpan_authors{$1} ||= [];
+        }
+        elsif( m{^\./modules/by-module/(.+):} )
+        {
+            $storage = $cpan_modules{$1} ||= [];
+        }
+        elsif( m{\..*:} )
+        {
+            undef($storage);
+        }
+        else
+        {
+            next unless $storage;
+
+            my(
+                $perm, $ln, $o, $g, $size, $month, $day, $time, $what, $where,
+            ) =  split(/\s+/);
+
+            next unless $what and $what =~ /(?:tar\.gz|\.tgz|\.zip|\.tar\.bz2|\.tbz)$/;
+
+            push @$storage, $what;
+        }
+    }
+
+    to_cache(\%cpan_modules, 'cpan_modules');
+    to_cache(\%cpan_authors, 'cpan_authors');
+} unless from_cache(\%cpan_authors, 'cpan_authors', 12)
+    and from_cache(\%cpan_modules, 'cpan_modules', 12);
+
 my $cpan;   # instance of Parse::CPAN::Packages
 do {
 #    my $url = "$CPAN_MIRROR/modules/02packages.details.txt.gz";
@@ -191,8 +266,8 @@
 
         return $r if $r;
 
-        $a =~ s/^(\d*)//; my $a_d = defined($1) ? $1 : -1;
-        $b =~ s/^(\d*)//; my $b_d = defined($1) ? $1 : -1;
+        $a =~ s/^(\d*)//; my $a_d = (defined($1) and $1 ne '') ? $1 : -1;
+        $b =~ s/^(\d*)//; my $b_d = (defined($1) and $1 ne '') ? $1 : -1;
 
         $r = $a_d <=> $b_d;
 
@@ -219,6 +294,71 @@
 }
 
 sub latest_upstream_from_cpan($$)
+{
+    my ($watch, $pkg) = @_;
+
+    my @cpan = grep( m{^(?:http|ftp)://.*cpan}i, @$watch );
+
+    return undef unless @cpan;
+
+    my @vers;
+
+    foreach(@cpan)
+    {
+        if( s{^(?:http|ftp)://.*cpan.*/modules/by-module/}{} )
+        {
+            # lookup by module
+
+            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/}{} )
+        {
+            # lookup by author
+
+            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/;
+            }
+        }
+        else
+        {
+            debugmsg( sprintf( "    can't determine typo of search for %s\n", $_ ) );
+            return undef;
+        }
+    }
+
+    @vers = sort { cmp_ver($a,$b) } @vers;
+
+    return $vers[-1] || '';
+}
+
+sub latest_upstream_from_cpan_legacy($$)
 {
     my ($watch, $pkg) = @_;