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