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