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