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