1#!/usr/bin/perl 2 3use strict; 4use CPAN; 5use File::Basename (); 6use Getopt::Long (); 7use IO::File; 8use Proc::Reliable; 9 10my $URLprefix = 'http://search.cpan.org/CPAN/authors/id'; 11 12my($download, $file); 13Getopt::Long::GetOptions('d' => \$download, 'f=s', \$file); 14 15CPAN::HandleConfig->load; 16CPAN::Shell::setup_output; 17CPAN::Index->reload; 18 19sub nameVers { 20 my $x = shift; 21 my @parts = split('-', $x); 22 my $vers = pop(@parts); 23 (join('-', @parts), $vers) 24} 25 26my @modules; 27if(defined($file)) { 28 my $F = IO::File->new($file) or die "Can't open $file\n"; 29 while(<$F>) { 30 chomp; 31 push(@modules, $_); 32 } 33 undef($F); 34} else { 35 die "Usage: $0 [-f file] [module ...]\n" unless scalar(@ARGV) > 0; 36 @modules = @ARGV; 37} 38 39my($dist, $found, $foundvers, $name, $vers, %projects); 40my $curl = Proc::Reliable->new(); # use default retry count and times 41my @curlargs = qw(curl -O); 42my %downloaded; 43for my $m (@modules) { 44 printf "Looking for %s\n", $m; 45 undef($found); 46 my $mname = $m; 47 $mname =~ s/-/::/g; 48 for my $mod (CPAN::Shell->expand("Module", "/$mname/")) { 49 $dist = $mod->distribution; 50 next unless defined($dist); 51 ($name, $vers) = nameVers($dist->base_id); 52 next unless $name eq $mname; 53 if(defined($found)) { 54 unless($vers gt $foundvers) { 55 print " Previous $name-$foundvers preferred over $name-$vers\n"; 56 next; 57 } 58 print " Preferring $name-$vers over previous $name-$foundvers\n"; 59 } else { 60 print " Found $name-$vers\n"; 61 } 62 $found = $dist; 63 $foundvers = $vers; 64 } 65 if(!defined($found)) { 66 for my $dist (CPAN::Shell->expand("Distribution", "/\/$m-/")) { 67 ($name, $vers) = nameVers($dist->base_id); 68 next unless $name eq $m; 69 if(defined($found)) { 70 unless($vers gt $foundvers) { 71 print " Previous $name-$foundvers preferred over $name-$vers\n"; 72 next; 73 } 74 print " Preferring $name-$vers over previous $name-$foundvers\n"; 75 } else { 76 print " Found $name-$vers\n"; 77 } 78 $found = $dist; 79 $foundvers = $vers; 80 } 81 if(!defined($found)) { 82 print "***Can't find $m\n"; 83 next; 84 } 85 } 86 if($downloaded{$found->base_id}) { 87 printf " %s downloaded %s\n", $download ? 'Already' : 'Would have already', $found->base_id; 88 next; 89 } 90 $downloaded{$found->base_id} = 1; 91 ($name, $vers) = nameVers($found->base_id); 92 my $url = $found->pretty_id; 93 my $tarball = File::Basename::basename($url); 94 my $a = substr($url, 0, 1); 95 my $a2 = substr($url, 0, 2); 96 $url = join('/', $URLprefix, $a, $a2, $url); 97 #printf "%s-%s => %s-%s\n", $m, $projects{$m}, $name, $vers; 98 if($download) { 99 print " Downloading $url\n"; 100 $curlargs[2] = $url; 101 my($out, $err, $status, $msg) = $curl->run(\@curlargs); 102 if($status != 0 || `file $tarball` !~ /gzip compressed data/) { 103 warn "***\"@curlargs\" failed: $msg\n"; 104 } 105 } else { 106 print " Would download $url\n"; 107 } 108} 109