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