5 Porting/sync-with-cpan - Synchronize with CPAN distributions
9 perl Porting/sync-with-cpan <module>
11 where <module> is the name it appears in the C<%Modules> hash
12 of F<Porting/Maintainers.pl>
16 Script to help out with syncing cpan distros.
24 Fetches the package list from CPAN. Finds the current version of the given
29 Downloads the relevant tarball; unpacks the tarball. [1]
33 Clean out the old directory (C<git clean -dfx>)
37 Moves the old directory out of the way, moves the new directory in place.
41 Restores any F<.gitignore> file.
45 Removes files from C<@IGNORE> and C<EXCLUDED>
49 C<git add> any new files.
53 C<git rm> any files that are gone.
57 Remove the +x bit on files in F<t/>
61 Remove the +x bit on files that don't have it enabled in the current dir
65 Restore files mentioned in C<CUSTOMIZED>
69 Adds new files to F<MANIFEST>
73 Runs a C<make> (assumes a configure has been run)
81 Runs tests for the package
85 Runs the porting tests
89 [1] If the C<--tarball> option is given, then CPAN is not consulted.
90 C<--tarball> should be the path to the tarball; the version is extracted
91 from the filename -- but can be overwritten by the C<--version> option.
99 Delete files from F<MANIFEST>
103 Update F<Porting/Maintainers.pl>
107 Optional, run a full test suite
111 Handle complicated C<FILES>
115 This is an initial version; no attempt has been made yet to make this
116 portable. It shells out instead of trying to find a Perl solution.
117 In particular, it assumes git, perl, and make
131 use File::Path qw( remove_tree );
133 use Config qw( %Config );
137 die "This does not look like a top level directory"
138 unless -d "cpan" && -d "Porting";
145 require "Porting/Maintainers.pl";
147 my %IGNORABLE = map {$_ => 1} @IGNORABLE;
149 my $tmpdir= $ENV{ TEMP } // '/tmp';
151 my $package = "02packages.details.txt";
152 my $package_url = "http://www.cpan.org/modules/$package";
153 my $package_file = "$tmpdir/$package"; # this is a cache
156 'podlators', # weird CUSTOMIZED section due to .PL files
160 GetOptions ('tarball=s' => \my $tarball,
161 'version=s' => \my $version,
162 force => \my $force,)
163 or die "Failed to parse arguments";
165 die "Usage: $0 module [args] [cpan package]" unless @ARGV == 1 || @ARGV == 2;
169 find( { no_chdir => 1, wanted => sub {
170 my $file= $File::Find::name;
171 return unless -f $file;
177 # Equivalent of `chmod a-x`
179 for my $filename ( @_ ) {
180 my $mode= (stat $filename)[2] & 0777;
181 if( $mode & 0111 ) { # exec-bit set
182 chmod $mode & 0666, $filename;
189 if( $^O eq 'MSWin32') {
191 system "$Config{make} @args> ..\\make.log 2>&1" and die "Running make failed, see make.log";
194 system "$Config{make} @args> make.log 2>&1" and die "Running make failed, see make.log";
198 my ($module) = shift;
199 my $cpan_mod = @ARGV ? shift : $module;
202 my $info = $Modules {$module} or die "Cannot find module $module";
203 my $distribution = $$info {DISTRIBUTION};
205 my @files = glob $$info {FILES};
206 if (!-d $files [0] || grep { $_ eq $module } @problematic) {
207 say "This looks like a setup $0 cannot handle (yet)";
209 say "Will not continue without a --force option";
212 say "--force is in effect, so we'll soldier on. Wish me luck!";
218 my $pkg_dir = $files[0];
221 my ($old_version) = $distribution =~ /-([0-9.]+(?:-TRIAL[0-9]*)?)\.tar\.gz/;
223 my $o_module = $module;
224 if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
225 $cpan_mod =~ s/-/::/g;
229 # Find the information from CPAN.
237 unless (-f $package_file && -M $package_file < 1) {
240 my $http= HTTP::Tiny->new();
241 $http->mirror( $package_url => $package_file );
243 } or system wget => $package_url, '-qO', $package_file;
246 open my $fh, '<', $package_file;
247 (my $new_line) = grep {/^$cpan_mod/} <$fh> # Yes, this needs a lot of memory
248 or die "Cannot find $cpan_mod on CPAN\n";
249 (undef, $new_version, my $new_path) = split ' ', $new_line;
250 if (defined $version) {
251 $new_path =~ s/-$new_version\./-$version\./;
252 $new_version = $version;
254 $new_file = (split '/', $new_path) [-1];
256 my $url = "http://search.cpan.org/CPAN/authors/id/$new_path";
259 # Fetch the new distro
263 my $http= HTTP::Tiny->new();
264 $http->mirror( $url => $new_file );
266 } or system wget => $url, '-qO', $new_file;
269 $new_file = $tarball;
270 $new_version = $version // ($new_file =~ /-([0-9._]+(?:-TRIAL[0-9]*)?)\.tar\.gz/) [0];
273 my $old_dir = "$pkg_dir-$old_version";
275 say "Cleaning out old directory";
276 system git => 'clean', '-dfxq', $pkg_dir;
278 say "Unpacking $new_file";
279 Archive::Tar->extract_archive( $new_file );
281 (my $new_dir = $new_file) =~ s/\.tar\.gz//;
282 # ensure 'make' will update all files
284 for my $file (find_type_f($new_dir)) {
285 open(my $fh,">>$file") || die "Cannot write $file:$!";
290 say "Renaming directories";
291 rename $pkg_dir => $old_dir;
293 say "Creating new package directory";
296 say "Populating new package directory";
297 my $map = $$info {MAP};
300 if ($$info {EXCLUDED}) {
301 foreach my $entry (@{$$info {EXCLUDED}}) {
302 if (ref $entry) {push @EXCLUDED_QR => $entry}
303 else {$EXCLUDED_QQ {$entry} = 1}
307 FILE: for my $file ( find_type_f( $new_dir )) {
308 my $old_file = $file;
309 $file =~ s{^$new_dir/}{};
311 next if $EXCLUDED_QQ{$file};
312 for my $qr (@EXCLUDED_QR) {
313 next FILE if $file =~ $qr;
317 for my $key ( sort { length $b <=> length $a } keys %$map ) {
318 my $val = $map->{$key};
319 last if $file =~ s/^$key/$val/;
323 $file = $files[0] . '/' . $file;
326 if ( $file =~ m{^cpan/} ) {
327 $file =~ s{^cpan/}{};
330 $file = '../' . $file;
334 my @parts = split '/', $file;
336 for my $part (@parts) {
337 $prefix .= '/' if $prefix;
339 mkdir $prefix unless -d $prefix;
342 rename $old_file => $file;
344 remove_tree( $new_dir );
346 if (-f "$old_dir/.gitignore") {
347 say "Restoring .gitignore";
348 system git => 'checkout', "$pkg_dir/.gitignore";
351 my @new_files = find_type_f( $pkg_dir );
352 @new_files = grep {$_ ne $pkg_dir} @new_files;
353 s!^[^/]+/!! for @new_files;
354 my %new_files = map {$_ => 1} @new_files;
356 my @old_files = find_type_f( $old_dir );
357 @old_files = grep {$_ ne $old_dir} @old_files;
358 s!^[^/]+/!! for @old_files;
359 my %old_files = map {$_ => 1} @old_files;
365 foreach my $file (@new_files) {
366 next if -d "$pkg_dir/$file"; # Ignore directories.
367 next if $old_files {$file}; # It's already there.
368 if ($IGNORABLE {$file}) {
369 push @delete => $file;
372 push @commit => $file;
374 foreach my $file (@old_files) {
375 next if -d "$old_dir/$file";
376 next if $new_files {$file};
381 # Find all files with an exec bit
383 my @exec = find_type_f( $pkg_dir );
385 foreach my $file (@exec) {
387 $file =~ s!^[^/]+/!!;
388 if ($file =~ m!^t/!) {
389 push @de_exec => $file;
392 # Check to see if the file exists; if it doesn't and doesn't have
393 # the exec bit, remove it.
394 if ($old_files {$file}) {
395 unless (-x "$old_dir/$file") {
396 push @de_exec => $file;
402 # No need to change the +x bit on files that will be deleted.
404 if (@de_exec && @delete) {
405 my %delete = map {+"$pkg_dir/$_" => 1} @delete;
406 @de_exec = grep {!$delete {$_}} @de_exec;
409 say "unlink $pkg_dir/$_" for @delete;
410 say "git add $pkg_dir/$_" for @commit;
411 say "git rm -f $pkg_dir/$_" for @gone;
412 say "chmod a-x $pkg_dir/$_" for @de_exec;
414 print "Hit return to continue; ^C to abort "; <STDIN>;
416 unlink "$pkg_dir/$_" for @delete;
417 system git => 'add', "$pkg_dir/$_" for @commit;
418 system git => 'rm', '-f', "$pkg_dir/$_" for @gone;
419 de_exec( "$pkg_dir/$_" ) for @de_exec;
422 # Restore anything that is customized.
423 # We don't really care whether we've deleted the file - since we
424 # do a git restore, it's going to be resurrected if necessary.
426 if ($$info {CUSTOMIZED}) {
427 say "Restoring customized files";
428 foreach my $file (@{$$info {CUSTOMIZED}}) {
429 system git => "checkout", "$pkg_dir/$file";
435 say "Fixing MANIFEST";
436 my $MANIFEST = "MANIFEST";
437 my $MANIFEST_SORT = "$MANIFEST.sorted";
438 open my $fh, ">>", $MANIFEST;
439 say $fh "cpan/$pkg_dir/$_" for @commit;
441 system perl => "Porting/manisort", '--output', $MANIFEST_SORT;
442 rename $MANIFEST_SORT => $MANIFEST;
446 print "Running a make ... ";
447 # Prepare for running (selected) tests
452 # Must clean up, or else t/porting/FindExt.t will fail.
453 # Note that we can always retrieve the original directory with a git checkout.
455 print "About to clean up; hit return or abort (^C) "; <STDIN>;
457 remove_tree( "cpan/$old_dir" );
458 unlink "cpan/$new_file" unless $tarball;
461 # Run the tests. First the test belonging to the module, followed by the
462 # the tests in t/porting
465 say "Running module tests";
466 my @test_files = grep { /\.t$/ } find_type_f( $pkg_dir );
467 my $exe_dir= $^O =~ /MSWin/ ? "..\\" : './';
468 my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`;
469 unless ($output =~ /All tests successful/) {
474 print "Running tests in t/porting ";
475 my @tests = glob 'porting/*.t';
478 foreach my $t (@tests) {
479 my @not = grep {!/# TODO/ }
481 `${exe_dir}perl -I../lib -I.. $t`;
482 print @not ? '!' : '.';
483 push @failed => $t if @not;
486 say "Failed tests: @failed" if @failed;
489 say "Attempting to update Maintainers.pl";
492 open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
493 open my $new_Maintainers_pl, '>', 'Maintainers.pl';
497 while (<$Maintainers_pl>) {
499 if ($in_mod_section) {
500 if (/DISTRIBUTION/) {
501 if (s/\Q$old_version/$new_version/) {
516 print $new_Maintainers_pl $_;
520 unlink 'Porting/Maintainers.pl';
521 rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
522 chmod 0755 => 'Porting/Maintainers.pl';
525 say "Could not update Porting/Maintainers.pl.";
526 say "Make sure you update this by hand before committing.";
529 say "$o_module is now version $new_version";
530 say "Now you ought to run a make; make test ...";