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