This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
f81e14abaec2827acb4cf0eeef1b6a3a8a2a532e
[perl5.git] / Porting / sync-with-cpan
1 #!/usr/bin/env perl
2
3 =head1 NAME
4
5 Porting/sync-with-cpan - Synchronize with CPAN distributions
6
7 =head1 SYNOPSIS
8
9   perl Porting/sync-with-cpan <module>
10
11 where <module> is the name it appears in the C<%Modules> hash
12 of F<Porting/Maintainers.pl>
13
14 =head1 DESCRIPTION
15
16 Script to help out with syncing cpan distros.
17
18 Does the following:
19
20 =over 4
21
22 =item *
23
24 Fetches the package list from CPAN. Finds the current version of the given
25 package. [1]
26
27 =item *
28
29 Downloads the relevant tarball; unpacks the tarball. [1]
30
31 =item *
32
33 Clean out the old directory (C<git clean -dfx>)
34
35 =item *
36
37 Moves the old directory out of the way, moves the new directory in place.
38
39 =item *
40
41 Restores any F<.gitignore> file.
42
43 =item *
44
45 Removes files from C<@IGNORE> and C<EXCLUDED>
46
47 =item *
48
49 C<git add> any new files.
50
51 =item *
52
53 C<git rm> any files that are gone.
54
55 =item *
56
57 Remove the +x bit on files in F<t/>
58
59 =item *
60
61 Remove the +x bit on files that don't have it enabled in the current dir
62
63 =item *
64
65 Restore files mentioned in C<CUSTOMIZED>
66
67 =item *
68
69 Updates the contents of F<MANIFEST>
70
71 =item *
72
73 Runs a C<make> (assumes a configure has been run)
74
75 =item *
76
77 Cleans up
78
79 =item *
80
81 Runs tests for the package
82
83 =item *
84
85 Runs the porting tests
86
87 =back
88
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.
92
93 =head1 OPTIONS
94
95 =over 4
96
97 =item C<--jobs> I<N>
98
99 When running C<make>, pass a C<< -jI<N> >> option to it.
100
101 =back
102
103 =head1 TODO
104
105 =over 4
106
107 =item *
108
109 Update F<Porting/Maintainers.pl>
110
111 =item *
112
113 Optional, run a full test suite
114
115 =item *
116
117 Handle complicated C<FILES>
118
119 =back
120
121 This is an initial version; no attempt has been made yet to make this
122 portable. It shells out instead of trying to find a Perl solution.
123 In particular, it assumes git, perl, and make
124 to be available.
125
126 =cut
127
128
129 package Maintainers;
130
131 use 5.010;
132
133 use strict;
134 use warnings;
135 use Getopt::Long;
136 use Archive::Tar;
137 use File::Basename qw( basename );
138 use File::Path qw( remove_tree );
139 use File::Find;
140 use File::Spec::Functions qw( tmpdir rel2abs );
141 use Config qw( %Config );
142
143 $| = 1;
144
145 use constant WIN32 => $^O eq 'MSWin32';
146
147 die "This does not look like a top level directory"
148      unless -d "cpan" && -d "Porting";
149
150 # Check that there's a Makefile, if needed; otherwise, we'll do most of our
151 # work only to fail when we try to run make, and the user will have to
152 # either unpick everything we've done, or do the rest manually.
153 die "Please run Configure before using $0\n"
154     if !WIN32 && !-f "Makefile";
155
156 our @IGNORABLE;
157 our %Modules;
158
159 use autodie;
160
161 require "./Porting/Maintainers.pl";
162
163 my $MAKE_LOG = 'make.log';
164
165 my %IGNORABLE    = map {$_ => 1} @IGNORABLE;
166
167 my $tmpdir = tmpdir();
168
169 my $package      = "02packages.details.txt";
170 my $package_url  = "http://www.cpan.org/modules/$package";
171 my $package_file = "$tmpdir/$package"; # this is a cache
172
173 my @problematic = (
174     'podlators', # weird CUSTOMIZED section due to .PL files
175 );
176
177
178 sub usage
179 {
180     my $err = shift and select STDERR;
181     print "Usage: $0 module [args] [cpan package]\n";
182     exit $err;
183 }
184
185 GetOptions ('tarball=s'  =>  \my $tarball,
186             'version=s'  =>  \my $version,
187             'jobs=i'     =>  \my $make_jobs,
188              force       =>  \my $force,
189              help        =>  sub { usage 0; },
190              ) or  die "Failed to parse arguments";
191
192 usage 1 unless @ARGV == 1 || @ARGV == 2;
193
194 sub find_type_f {
195     my @res;
196     find( { no_chdir => 1, wanted => sub {
197         my $file= $File::Find::name;
198         return unless -f $file;
199         push @res, $file
200     }}, @_ );
201     @res
202 };
203
204 # Equivalent of `chmod a-x`
205 sub de_exec {
206     my ($filename) = @_;
207     my $mode = (stat $filename)[2] & 0777;
208     if ($mode & 0111) { # exec-bit set
209         chmod $mode & 0666, $filename;
210     }
211 }
212
213 # Equivalent of `chmod +w`
214 sub make_writable {
215     my ($filename) = @_;
216     my $mode = (stat $filename)[2] & 0777;
217     if (!($mode & 0222)) { # not writable
218         chmod $mode | (0222 & ~umask), $filename;
219     }
220 }
221
222 sub make {
223     my @args= @_;
224     unshift @args, "-j$make_jobs" if defined $make_jobs;
225     if (WIN32) {
226         chdir "Win32";
227         system "$Config{make} @args> ..\\$MAKE_LOG 2>&1"
228             and die "Running make failed, see $MAKE_LOG";
229         chdir '..';
230     } else {
231         system "$Config{make} @args> $MAKE_LOG 2>&1"
232             and die "Running make failed, see $MAKE_LOG";
233     };
234 };
235
236 my ($module)  = shift;
237
238 my $info = $Modules{$module};
239 if (!$info) {
240     # Maybe the user said "Test-Simple" instead of "Test::Simple", or
241     # "IO::Compress" instead of "IO-Compress". See if we can fix it up.
242     my $guess = $module;
243     s/-/::/g or s/::/-/g for $guess;
244     $info = $Modules{$guess} or die <<"EOF";
245 Cannot find module $module.
246 The available options are listed in the %Modules hash in Porting/Maintainers.pl
247 EOF
248     say "Guessing you meant $guess instead of $module";
249     $module = $guess;
250 }
251
252 if ($info->{CUSTOMIZED}) {
253     print <<"EOF";
254 $module has a CUSTOMIZED entry in Porting/Maintainers.pl.
255
256 This program's behaviour is to copy every CUSTOMIZED file into the version
257 of the module being imported. But that might not be the right thing: in some
258 cases, the new CPAN version will supersede whatever changes had previously
259 been made in blead, so it would be better to import the new CPAN files.
260
261 If you've checked that the CUSTOMIZED versions are still correct, you can
262 proceed now. Otherwise, you should abort and investigate the situation. If
263 the blead customizations are no longer needed, delete the CUSTOMIZED entry
264 for $module in Porting/Maintainers.pl (and you'll also need to regenerate
265 t/porting/customized.dat in that case; see t/porting/customized.t).
266
267 EOF
268     print "Hit return to continue; ^C to abort "; <STDIN>;
269 }
270
271 my $cpan_mod = @ARGV ? shift : $module;
272
273 my  $distribution = $$info {DISTRIBUTION};
274
275 my @files         = glob $$info {FILES};
276 if (!-d $files [0] || grep { $_ eq $module } @problematic) {
277     say "This looks like a setup $0 cannot handle (yet)";
278     unless ($force) {
279         say "Will not continue without a --force option";
280         exit 1;
281     }
282     say "--force is in effect, so we'll soldier on. Wish me luck!";
283 }
284
285 use Cwd 'cwd';
286 my $orig_pwd = cwd();
287
288 chdir "cpan";
289
290 my  $pkg_dir      = $files[0];
291     $pkg_dir      =~ s!.*/!!;
292
293 my ($old_version) = $distribution =~ /-([0-9.]+(?:-TRIAL[0-9]*)?)\.tar\.gz/;
294
295 my  $o_module     = $module;
296 if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
297     $cpan_mod =~ s/-/::/g;
298 }
299
300 sub wget {
301     my ($url, $saveas) = @_;
302     eval {
303         require HTTP::Tiny;
304         my $http= HTTP::Tiny->new();
305         $http->mirror( $url => $saveas );
306         1
307     } or
308        # Some system do not have wget.  Fall back to curl if we do not
309        # have it.  On Windows, `which wget` is not going to work, so
310        # just use wget, as this script has always done.
311        WIN32 || -x substr(`which wget`, 0, -1)
312          ? system wget => $url, '-qO', $saveas
313          : system curl => $url, '-sSo', $saveas;
314 }
315
316 #
317 # Find the information from CPAN.
318 #
319 my $new_file;
320 my $new_version;
321 if (defined $tarball) {
322     $tarball = rel2abs( $tarball, $orig_pwd ) ;
323     die "Tarball $tarball does not exist\n" if !-e $tarball;
324     die "Tarball $tarball is not a plain file\n" if !-f _;
325     $new_file     = $tarball;
326     $new_version  = $version // ($new_file =~ /-([0-9._]+(?:-TRIAL[0-9]*)?)\.tar\.gz/) [0];
327     die "Blead and that tarball both have version $new_version of $module\n"
328         if $new_version eq $old_version;
329 }
330 else {
331     #
332     # Poor man's cache
333     #
334     unless (-f $package_file && -M $package_file < 1) {
335         wget $package_url, $package_file;
336     }
337
338     open my $fh, '<', $package_file;
339     (my $new_line) = grep {/^$cpan_mod/} <$fh> # Yes, this needs a lot of memory
340                      or die "Cannot find $cpan_mod on CPAN\n";
341     (undef, $new_version, my $new_path) = split ' ', $new_line;
342     if (defined $version) {
343         $new_path =~ s/-$new_version\./-$version\./;
344         $new_version = $version;
345     }
346     $new_file = (split '/', $new_path) [-1];
347
348     die "The latest version of $module is $new_version, but blead already has it\n"
349         if $new_version eq $old_version;
350
351     my $url = "https://cpan.metacpan.org/authors/id/$new_path";
352     say "Fetching $url";
353     #
354     # Fetch the new distro
355     #
356     wget $url, $new_file;
357 }
358
359 my  $old_dir      = "$pkg_dir-$old_version";
360
361 say "Cleaning out old directory";
362 system git => 'clean', '-dfxq', $pkg_dir;
363
364 say "Unpacking $new_file";
365 Archive::Tar->extract_archive( $new_file );
366
367 (my $new_dir = basename($new_file)) =~ s/\.tar\.gz//;
368 # ensure 'make' will update all files
369 my $t= time;
370 for my $file (find_type_f($new_dir)) {
371     make_writable($file); # for convenience if the user later edits it
372     utime($t,$t,$file);
373 };
374
375 say "Renaming directories";
376 rename $pkg_dir => $old_dir;
377
378 say "Creating new package directory";
379 mkdir $pkg_dir;
380
381 say "Populating new package directory";
382 my $map = $$info {MAP};
383 my @EXCLUDED_QR;
384 my %EXCLUDED_QQ;
385 if ($$info {EXCLUDED}) {
386     foreach my $entry (@{$$info {EXCLUDED}}) {
387         if (ref $entry) {push @EXCLUDED_QR => $entry}
388         else            {$EXCLUDED_QQ {$entry} = 1}
389     }
390 }
391
392 FILE: for my $file ( find_type_f( $new_dir )) {
393     my $old_file = $file;
394     $file =~ s{^$new_dir/}{};
395
396     next if $EXCLUDED_QQ{$file};
397     for my $qr (@EXCLUDED_QR) {
398         next FILE if $file =~ $qr;
399     }
400
401     if ( $map ) {
402         for my $key ( sort { length $b <=> length $a } keys %$map ) {
403             my $val = $map->{$key};
404             last if $file =~ s/^$key/$val/;
405         }
406     }
407     else {
408         $file = $files[0] . '/' . $file;
409     }
410
411     if ( $file =~ m{^cpan/} ) {
412         $file =~ s{^cpan/}{};
413     }
414     else {
415         $file = '../' . $file;
416     }
417
418     my $prefix = '';
419     my @parts = split '/', $file;
420     pop @parts;
421     for my $part (@parts) {
422         $prefix .= '/' if $prefix;
423         $prefix .= $part;
424         mkdir $prefix unless -d $prefix;
425     }
426
427     rename $old_file => $file;
428 }
429 remove_tree( $new_dir );
430
431 if (-f "$old_dir/.gitignore") {
432     say "Restoring .gitignore";
433     system git => 'checkout', "$pkg_dir/.gitignore";
434 }
435
436 my @new_files = find_type_f( $pkg_dir );
437 @new_files = grep {$_ ne $pkg_dir} @new_files;
438 s!^[^/]+/!! for @new_files;
439 my %new_files = map {$_ => 1} @new_files;
440
441 my @old_files = find_type_f( $old_dir );
442 @old_files = grep {$_ ne $old_dir} @old_files;
443 s!^[^/]+/!! for @old_files;
444 my %old_files = map {$_ => 1} @old_files;
445
446 my @delete;
447 my @commit;
448 my @gone;
449 FILE:
450 foreach my $file (@new_files) {
451     next if -d "$pkg_dir/$file";   # Ignore directories.
452     next if $old_files {$file};    # It's already there.
453     if ($IGNORABLE {$file}) {
454         push @delete => $file;
455         next;
456     }
457     push @commit => $file;
458 }
459 foreach my $file (@old_files) {
460     next if -d "$old_dir/$file";
461     next if $new_files {$file};
462     push @gone => $file;
463 }
464
465 #
466 # Find all files with an exec bit
467 #
468 my @exec = find_type_f( $pkg_dir );
469 my @de_exec;
470 foreach my $file (@exec) {
471     # Remove leading dir
472     $file =~ s!^[^/]+/!!;
473     if ($file =~ m!^t/!) {
474         push @de_exec => $file;
475         next;
476     }
477     # Check to see if the file exists; if it doesn't and doesn't have
478     # the exec bit, remove it.
479     if ($old_files {$file}) {
480         unless (-x "$old_dir/$file") {
481             push @de_exec => $file;
482         }
483     }
484 }
485
486 #
487 # No need to change the +x bit on files that will be deleted.
488 #
489 if (@de_exec && @delete) {
490     my %delete = map {+"$pkg_dir/$_" => 1} @delete;
491     @de_exec = grep {!$delete {$_}} @de_exec;
492 }
493
494 #
495 # Mustn't change the +x bit on files that are whitelisted
496 #
497 if (@de_exec) {
498     my %permitted = map { (my $x = $_) =~ tr/\n//d; $x => 1 } grep !/^#/,
499         do { local @ARGV = '../Porting/exec-bit.txt'; <> };
500     @de_exec = grep !$permitted{"cpan/$pkg_dir/$_"}, @de_exec;
501 }
502
503 say "unlink $pkg_dir/$_" for @delete;
504 say "git add $pkg_dir/$_" for @commit;
505 say "git rm -f $pkg_dir/$_" for @gone;
506 say "chmod a-x $pkg_dir/$_" for @de_exec;
507
508 print "Hit return to continue; ^C to abort "; <STDIN>;
509
510 unlink "$pkg_dir/$_"                      for @delete;
511 system git   => 'add', "$pkg_dir/$_"      for @commit;
512 system git   => 'rm', '-f', "$pkg_dir/$_" for @gone;
513 de_exec( "$pkg_dir/$_" )                  for @de_exec;
514
515 #
516 # Restore anything that is customized.
517 # We don't really care whether we've deleted the file - since we
518 # do a git restore, it's going to be resurrected if necessary.
519 #
520 if ($$info {CUSTOMIZED}) {
521     say "Restoring customized files";
522     foreach my $file (@{$$info {CUSTOMIZED}}) {
523         system git => "checkout", "$pkg_dir/$file";
524     }
525 }
526
527 chdir "..";
528 if (@commit || @gone) {
529     say "Fixing MANIFEST";
530     my $MANIFEST     = "MANIFEST";
531     my $MANIFEST_NEW = "$MANIFEST.new";
532
533     open my $orig, "<", $MANIFEST
534         or die "Failed to open $MANIFEST for reading: $!\n";
535     open my $new, ">", $MANIFEST_NEW
536         or die "Failed to open $MANIFEST_NEW for writing: $!\n";
537     my %gone = map +("cpan/$pkg_dir/$_" => 1), @gone;
538     while (my $line = <$orig>) {
539         my ($file) = $line =~ /^(\S+)/
540             or die "Can't parse MANIFEST line: $line";
541         print $new $line if !$gone{$file};
542     }
543
544     say $new "cpan/$pkg_dir/$_" for @commit;
545
546     close $new or die "Can't close $MANIFEST: $!\n";
547
548     system $^X => "Porting/manisort", '--quiet', "--output=$MANIFEST", $MANIFEST_NEW;
549     unlink $MANIFEST_NEW
550         or die "Can't delete temporary $MANIFEST_NEW: $!\n";
551 }
552
553
554 print "Running a make and saving its output to $MAKE_LOG ... ";
555 # Prepare for running (selected) tests
556 make 'test-prep';
557 print "done\n";
558
559 # The build system installs code from CPAN dists into the lib/ directory,
560 # creating directories as needed. This means that the cleaning-related rules
561 # in the Makefile need to know which directories to clean up. The Makefile
562 # is generated by Configure from Makefile.SH, so *that* file needs the list
563 # of directories. regen/lib_cleanup.pl is capable of automatically updating
564 # the contents of Makefile.SH (and win32/Makefile, which needs similar but
565 # not identical lists of directories), so we can just run that (using the
566 # newly-built Perl, as is done with the regen programs run by "make regen").
567 #
568 # We do this if any files at all have been added or deleted, regardless of
569 # whether those changes result in any directories being added or deleted,
570 # because the alternative would be to replicate the regen/lib_cleanup.pl
571 # logic here. That's fine, because regen/lib_cleanup.pl is idempotent if run
572 # repeatedly.
573 if (@commit || @gone) {
574     say "Running regen/lib_cleanup.pl to handle potential added/deleted dirs";
575     my $exe_dir = WIN32 ? ".\\" : './';
576     system "${exe_dir}perl$Config{_exe}", "-Ilib", "regen/lib_cleanup.pl"
577         and die "regen/lib_cleanup.pl failed\n";
578 }
579
580 #
581 # Must clean up, or else t/porting/FindExt.t will fail.
582 # Note that we can always retrieve the original directory with a git checkout.
583 #
584 print "About to clean up; hit return or abort (^C) "; <STDIN>;
585
586 remove_tree( "cpan/$old_dir" );
587 unlink "cpan/$new_file" unless $tarball;
588
589 #
590 # Run the tests. First the test belonging to the module, followed by the
591 # the tests in t/porting
592 #
593 chdir "t";
594 say "Running module tests";
595 my @test_files = grep { /\.t$/ } find_type_f( "../cpan/$pkg_dir" );
596 my $exe_dir = WIN32 ? "..\\" : './';
597 my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`;
598 unless ($output =~ /All tests successful/) {
599     say $output;
600     exit 1;
601 }
602
603 print "Running tests in t/porting ";
604 my @tests = glob 'porting/*.t';
605 chomp @tests;
606 my @failed;
607 foreach my $t (@tests) {
608     my @not = grep {!/# TODO/ }
609               grep { /^not/ }
610               `${exe_dir}perl -I../lib -I.. $t`;
611     print @not ? '!' : '.';
612     push @failed => $t if @not;
613 }
614 print "\n";
615 say "Failed tests: @failed" if @failed;
616
617
618 chdir '..';
619
620 open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
621 open my $new_Maintainers_pl, '>', 'Maintainers.pl';
622
623 my $found;
624 my $in_mod_section;
625 while (<$Maintainers_pl>) {
626     if (!$found) {
627         if ($in_mod_section) {
628             if (/DISTRIBUTION/) {
629                 if (s/\Q$old_version/$new_version/) {
630                     $found = 1;
631                 }
632             }
633
634             if (/^    \}/) {
635                 $in_mod_section = 0;
636             }
637         }
638
639         if (/\Q$module/) {
640             $in_mod_section = 1;
641         }
642     }
643
644     print $new_Maintainers_pl $_;
645 }
646
647 if ($found) {
648     say "Successfully updated Maintainers.pl";
649     unlink 'Porting/Maintainers.pl';
650     rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
651     chmod 0755 => 'Porting/Maintainers.pl';
652 }
653 else {
654     say "Could not update Porting/Maintainers.pl.";
655     say "Make sure you update this by hand before committing.";
656 }
657
658 print <<"EOF";
659
660 =======================================================================
661
662 $o_module is now at version $new_version
663 Next, you should run a "make test".
664
665 Hopefully that will complete successfully, but if not, you can make any
666 changes you need to get the tests to pass. Don't forget that you'll need
667 a "CUSTOMIZED" entry in Porting/Maintainers.pl if you change any of the
668 files under cpan/$pkg_dir.
669
670 Once all tests pass, you can "git add -u" and "git commit" the changes.
671
672 EOF
673
674 __END__