1#!/usr/bin/perl
2
3use strict;
4use CPAN;
5use File::Basename ();
6use File::chdir;
7use Getopt::Long ();
8use IO::File;
9use Proc::Reliable;
10
11my $FileCurrent = '5.16.inc';
12my @FilePreviousList = qw(5.12.inc 5.10.inc);
13my $URLprefix = 'http://search.cpan.org/CPAN/authors/id';
14
15my $download;
16my @skip;
17my $skipfile;
18Getopt::Long::GetOptions('d' => \$download, 's=s' => \@skip, 'S=s' => \$skipfile);
19if(defined($skipfile)) {
20    my $s = IO::File->new($skipfile, 'r') or die "Can't open $skipfile\n";
21    while(<$s>) {
22	chomp;
23	push(@skip, $_);
24    }
25}
26my %Skip = map {($_, 1)} @skip;
27
28CPAN::HandleConfig->load;
29CPAN::Shell::setup_output;
30CPAN::Index->reload;
31
32sub importDate {
33    my($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime;
34    sprintf('%d-%02d-%02d', $year + 1900, $mon + 1, $mday);
35}
36
37sub nameVers {
38    local $_;
39    my $x = shift;
40    my @parts = split('-', $x);
41    my $vers = pop(@parts);
42    (join('-', @parts), $vers)
43}
44
45sub updatePlist {
46    my($pl, $vers, $url, $date) = @_;
47    my %h = (
48	OpenSourceVersion => $vers,
49	OpenSourceURL => $url,
50	OpenSourceImportDate => $date,
51    );
52    my $in = IO::File->new($pl, 'r') || die "Can't open $pl\n";
53    my $outf = "$pl.out";
54    my $out = IO::File->new($outf, 'w') || die "Can't create $outf\n";
55    local $_;
56    while(<$in>) {
57	last if m|^</dict>|;
58	if(m|<key>(\w+)</key>| && exists($h{$1})) {
59	    $out->print($_);
60	    $out->printf("        <string>%s</string>\n", $h{$1});
61	    $in->getline(); # skip next line
62	    delete($h{$1});
63	    next;
64	}
65	$out->print($_);
66    }
67    for(keys(%h)) {
68	$out->printf("        <key>%s</key>\n", $_);
69	$out->printf("        <string>%s</string>\n", $h{$_});
70    }
71    $out->print("</dict>\n");
72    undef($in);
73    undef($out);
74    rename($outf, $pl) || die "Can't rename $outf to $pl\n";
75}
76
77my($dist, $found, $foundvers, $name, $vers, %projectsCurrent, %projectsPrevious);
78my $F = IO::File->new($FileCurrent) or die "Can't open $FileCurrent\n";
79while(<$F>) {
80    next unless /-/;
81    chomp;
82    s/^\s+//;
83    s/\s+\\.*$//;
84    ($name, $vers) = nameVers($_);
85    my $v = $projectsCurrent{$name};
86    die "***Multiple entries for $name $v and $vers (possibly others)\n" if defined($v) && $v ne $vers;
87    $projectsCurrent{$name} = $vers;
88}
89undef($F);
90for my $prev (@FilePreviousList) {
91    $F = IO::File->new($prev) or die "Can't open $prev\n";
92    while(<$F>) {
93	next unless /-/;
94	chomp;
95	s/^\s+//;
96	s/\s+\\.*$//;
97	$projectsPrevious{$_} = 1;
98    }
99    undef($F);
100}
101
102my(%downloaded, %old2new);
103my $curl = Proc::Reliable->new(num_tries => 5, time_per_try => 30);
104my @curlargs = qw(curl -O);
105my @sedcmd = qw(sed -i .bak);
106my $importDate = importDate();
107for my $proj (sort(keys(%projectsCurrent))) {
108    my $oldvers = $projectsCurrent{$proj};
109    my $old = "$proj-$oldvers";
110    if($Skip{$old}) {
111	print "Skipping $old\n";
112	next;
113    }
114    print "Update for $old\n";
115    undef($found);
116    $_ = $proj;
117    s/-/::/g;
118    for my $mod (CPAN::Shell->expand("Module", "/$_/")) {
119	next unless $_ eq $mod->id;
120	$dist = $mod->distribution;
121	($name, $vers) = nameVers($dist->base_id);
122	if(defined($found)) {
123	    unless($vers gt $foundvers) {
124		print "    Previous $name-$foundvers preferred over $name-$vers\n";
125		next;
126	    }
127	    print "    Preferring $name-$vers over previous $name-$foundvers\n";
128	} else {
129	    print "    Found $name-$vers\n";
130	}
131	$found = $dist;
132	$foundvers = $vers;
133    }
134    if(!defined($found)) {
135	for my $dist (CPAN::Shell->expand("Distribution", "/\/$proj-/")) {
136	    ($name, $vers) = nameVers($dist->base_id);
137	    next unless $proj eq $name;
138	    if(defined($found)) {
139		unless($vers gt $foundvers) {
140		    print "    Previous $name-$foundvers preferred over $name-$vers\n";
141		    next;
142		}
143		print "    Preferring $name-$vers over previous $name-$foundvers\n";
144	    } else {
145		print "    Found $name-$vers\n";
146	    }
147	    $found = $dist;
148	    $foundvers = $vers;
149	}
150	if(!defined($found)) {
151	    print "***Can't find $proj\n";
152	    next;
153	}
154    }
155    my $new = $found->base_id;
156    if($downloaded{$new}) {
157	printf "    %s downloaded %s\n", $download ? 'Already' : 'Would have already', $new;
158	$old2new{$old} = "-$new";
159	next;
160    }
161    ($name, $vers) = nameVers($new);
162    if($name ne $proj) {
163	print "    *** Module $proj combined into $name\n";
164	next;
165    }
166    if($vers eq $oldvers) {
167	print "    Already have $name-$vers\n";
168	next;
169    }
170    my $url = $found->pretty_id;
171    my $tarball = File::Basename::basename($url);
172    my $a = substr($url, 0, 1);
173    my $a2 = substr($url, 0, 2);
174    $url = join('/', $URLprefix, $a, $a2, $url);
175    if(!$download) {
176	print "    Would download $url\n";
177	if(defined($projectsPrevious{$old})) {
178	    print "    Would make new directory $new by copying $old\n";
179	} else {
180	    print "    Would rename directory $old to $new\n";
181	}
182	next;
183    } else {
184	local $CWD = 'Modules'; # will return to current directory automatically on exiting block
185	print "    Downloading $url\n";
186	$curlargs[2] = $url;
187	my($out, $err, $status, $msg) = $curl->run(\@curlargs);
188	if($status != 0 || `file $tarball` !~ /gzip compressed data/) {
189	    warn "***\"@curlargs\" failed: $msg\n";
190	    next;
191	}
192	if(defined($projectsPrevious{$old})) {
193	    print "    Copying $old to $new\n";
194	    if(system('svn', 'cp', $old, $new) != 0) {
195		warn "***Can't svn cp $old $new\n";
196		unlink($tarball);
197		next;
198	    }
199	} else {
200	    print "    Renaming $old to $new\n";
201	    if(system('svn', 'mv', $old, $new) != 0) {
202		warn "***Can't svn mv $old $new\n";
203		unlink($tarball);
204		next;
205	    }
206	}
207	$CWD = $new;
208	if(system('svn', 'mv', "$old.tar.gz", $tarball) != 0) {
209	    warn "***Can't rename $old.tar.gz to $tarball\n";
210	}
211	rename("../$tarball", $tarball) or warn "***Couldn't move $tarball into $new\n";
212	my $svers = $oldvers;
213	$svers =~ s/\./\\./g;
214	my @args;
215	push(@args, '-e', "s/$proj/$name/") if $proj ne $name;
216	push(@args, '-e', "s/$svers/$vers/");
217	print "    Editing Makefile \"@sedcmd @args Makefile\"\n";
218	if(system(@sedcmd, @args, 'Makefile') != 0) {
219	    warn "***\"@sedcmd @args Makefile\" failed\n";
220	}
221	unlink('Makefile.bak');
222	print "    Editing oss.partial\n";
223	updatePlist('oss.partial', $vers, $url, $importDate);
224	$downloaded{$new} = 1;
225	$old2new{$old} = $new;
226    }
227}
228exit 0 unless $download;
229
230print "\nUpdating $FileCurrent\n";
231my $old = "$FileCurrent.bak";
232rename($FileCurrent, $old) or die "Can't rename $FileCurrent to $old\n";
233$F = IO::File->new($old) or die "Can't open $old\n";
234my $T = IO::File->new($FileCurrent, 'w') or die "Can't create $old\n";
235while(<$F>) {
236    unless(/-/) {
237	print $T $_;
238	next;
239    }
240    my $line = $_;
241    chomp;
242    s/^\s+//;
243    s/\s+\\.*$//;
244    my $new = $old2new{$_};
245    if(defined($new)) {
246	if(substr($new, 0, 1) eq '-') {
247	    printf "Removing %s (now part of %s)\n", $_, substr($new, 1);
248	    next;
249	}
250	$line =~ s/$_/$new/;
251    }
252    print $T $line;
253}
254undef($T);
255undef($F);
256unlink($old);
257