(perl #131836) avoid a use-after-free after parsing a "sub" keyword
[perl.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 );
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
286 chdir "cpan";
287
288 my  $pkg_dir      = $files[0];
289     $pkg_dir      =~ s!.*/!!;
290
291 my ($old_version) = $distribution =~ /-([0-9.]+(?:-TRIAL[0-9]*)?)\.tar\.gz/;
292
293 my  $o_module     = $module;
294 if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
295     $cpan_mod =~ s/-/::/g;
296 }
297
298 #
299 # Find the information from CPAN.
300 #
301 my $new_file;
302 my $new_version;
303 if (defined $tarball) {
304     die "Tarball $tarball does not exist\n" if !-e $tarball;
305     die "Tarball $tarball is not a plain file\n" if !-f _;
306     $new_file     = $tarball;
307     $new_version  = $version // ($new_file =~ /-([0-9._]+(?:-TRIAL[0-9]*)?)\.tar\.gz/) [0];
308     die "Blead and that tarball both have version $new_version of $module\n"
309         if $new_version eq $old_version;
310 }
311 else {
312     #
313     # Poor man's cache
314     #
315     unless (-f $package_file && -M $package_file < 1) {
316         eval {
317             require HTTP::Tiny;
318             my $http= HTTP::Tiny->new();
319             $http->mirror( $package_url => $package_file );
320             1
321         } or system wget => $package_url, '-qO', $package_file;
322     }
323
324     open my $fh, '<', $package_file;
325     (my $new_line) = grep {/^$cpan_mod/} <$fh> # Yes, this needs a lot of memory
326                      or die "Cannot find $cpan_mod on CPAN\n";
327     (undef, $new_version, my $new_path) = split ' ', $new_line;
328     if (defined $version) {
329         $new_path =~ s/-$new_version\./-$version\./;
330         $new_version = $version;
331     }
332     $new_file = (split '/', $new_path) [-1];
333
334     die "The latest version of $module is $new_version, but blead already has it\n"
335         if $new_version eq $old_version;
336
337     my $url = "https://cpan.metacpan.org/authors/id/$new_path";
338     say "Fetching $url";
339     #
340     # Fetch the new distro
341     #
342     eval {
343         require HTTP::Tiny;
344         my $http= HTTP::Tiny->new();
345         $http->mirror( $url => $new_file );
346         1
347     } or system wget => $url, '-qO', $new_file;
348 }
349
350 my  $old_dir      = "$pkg_dir-$old_version";
351
352 say "Cleaning out old directory";
353 system git => 'clean', '-dfxq', $pkg_dir;
354
355 say "Unpacking $new_file";
356 Archive::Tar->extract_archive( $new_file );
357
358 (my $new_dir = basename($new_file)) =~ s/\.tar\.gz//;
359 # ensure 'make' will update all files
360 my $t= time;
361 for my $file (find_type_f($new_dir)) {
362     make_writable($file); # for convenience if the user later edits it
363     utime($t,$t,$file);
364 };
365
366 say "Renaming directories";
367 rename $pkg_dir => $old_dir;
368
369 say "Creating new package directory";
370 mkdir $pkg_dir;
371
372 say "Populating new package directory";
373 my $map = $$info {MAP};
374 my @EXCLUDED_QR;
375 my %EXCLUDED_QQ;
376 if ($$info {EXCLUDED}) {
377     foreach my $entry (@{$$info {EXCLUDED}}) {
378         if (ref $entry) {push @EXCLUDED_QR => $entry}
379         else            {$EXCLUDED_QQ {$entry} = 1}
380     }
381 }
382
383 FILE: for my $file ( find_type_f( $new_dir )) {
384     my $old_file = $file;
385     $file =~ s{^$new_dir/}{};
386
387     next if $EXCLUDED_QQ{$file};
388     for my $qr (@EXCLUDED_QR) {
389         next FILE if $file =~ $qr;
390     }
391
392     if ( $map ) {
393         for my $key ( sort { length $b <=> length $a } keys %$map ) {
394             my $val = $map->{$key};
395             last if $file =~ s/^$key/$val/;
396         }
397     }
398     else {
399         $file = $files[0] . '/' . $file;
400     }
401
402     if ( $file =~ m{^cpan/} ) {
403         $file =~ s{^cpan/}{};
404     }
405     else {
406         $file = '../' . $file;
407     }
408
409     my $prefix = '';
410     my @parts = split '/', $file;
411     pop @parts;
412     for my $part (@parts) {
413         $prefix .= '/' if $prefix;
414         $prefix .= $part;
415         mkdir $prefix unless -d $prefix;
416     }
417
418     rename $old_file => $file;
419 }
420 remove_tree( $new_dir );
421
422 if (-f "$old_dir/.gitignore") {
423     say "Restoring .gitignore";
424     system git => 'checkout', "$pkg_dir/.gitignore";
425 }
426
427 my @new_files = find_type_f( $pkg_dir );
428 @new_files = grep {$_ ne $pkg_dir} @new_files;
429 s!^[^/]+/!! for @new_files;
430 my %new_files = map {$_ => 1} @new_files;
431
432 my @old_files = find_type_f( $old_dir );
433 @old_files = grep {$_ ne $old_dir} @old_files;
434 s!^[^/]+/!! for @old_files;
435 my %old_files = map {$_ => 1} @old_files;
436
437 my @delete;
438 my @commit;
439 my @gone;
440 FILE:
441 foreach my $file (@new_files) {
442     next if -d "$pkg_dir/$file";   # Ignore directories.
443     next if $old_files {$file};    # It's already there.
444     if ($IGNORABLE {$file}) {
445         push @delete => $file;
446         next;
447     }
448     push @commit => $file;
449 }
450 foreach my $file (@old_files) {
451     next if -d "$old_dir/$file";
452     next if $new_files {$file};
453     push @gone => $file;
454 }
455
456 #
457 # Find all files with an exec bit
458 #
459 my @exec = find_type_f( $pkg_dir );
460 my @de_exec;
461 foreach my $file (@exec) {
462     # Remove leading dir
463     $file =~ s!^[^/]+/!!;
464     if ($file =~ m!^t/!) {
465         push @de_exec => $file;
466         next;
467     }
468     # Check to see if the file exists; if it doesn't and doesn't have
469     # the exec bit, remove it.
470     if ($old_files {$file}) {
471         unless (-x "$old_dir/$file") {
472             push @de_exec => $file;
473         }
474     }
475 }
476
477 #
478 # No need to change the +x bit on files that will be deleted.
479 #
480 if (@de_exec && @delete) {
481     my %delete = map {+"$pkg_dir/$_" => 1} @delete;
482     @de_exec = grep {!$delete {$_}} @de_exec;
483 }
484
485 #
486 # Mustn't change the +x bit on files that are whitelisted
487 #
488 if (@de_exec) {
489     my %permitted = map +(tr/\n//dr => 1), grep !/^#/,
490         do { local @ARGV = '../Porting/exec-bit.txt'; <> };
491     @de_exec = grep !$permitted{"cpan/$pkg_dir/$_"}, @de_exec;
492 }
493
494 say "unlink $pkg_dir/$_" for @delete;
495 say "git add $pkg_dir/$_" for @commit;
496 say "git rm -f $pkg_dir/$_" for @gone;
497 say "chmod a-x $pkg_dir/$_" for @de_exec;
498
499 print "Hit return to continue; ^C to abort "; <STDIN>;
500
501 unlink "$pkg_dir/$_"                      for @delete;
502 system git   => 'add', "$pkg_dir/$_"      for @commit;
503 system git   => 'rm', '-f', "$pkg_dir/$_" for @gone;
504 de_exec( "$pkg_dir/$_" )                  for @de_exec;
505
506 #
507 # Restore anything that is customized.
508 # We don't really care whether we've deleted the file - since we
509 # do a git restore, it's going to be resurrected if necessary.
510 #
511 if ($$info {CUSTOMIZED}) {
512     say "Restoring customized files";
513     foreach my $file (@{$$info {CUSTOMIZED}}) {
514         system git => "checkout", "$pkg_dir/$file";
515     }
516 }
517
518 chdir "..";
519 if (@commit || @gone) {
520     say "Fixing MANIFEST";
521     my $MANIFEST     = "MANIFEST";
522     my $MANIFEST_NEW = "$MANIFEST.new";
523
524     open my $orig, "<", $MANIFEST
525         or die "Failed to open $MANIFEST for reading: $!\n";
526     open my $new, ">", $MANIFEST_NEW
527         or die "Failed to open $MANIFEST_NEW for writing: $!\n";
528     my %gone = map +("cpan/$pkg_dir/$_" => 1), @gone;
529     while (my $line = <$orig>) {
530         my ($file) = $line =~ /^(\S+)/
531             or die "Can't parse MANIFEST line: $line";
532         print $new $line if !$gone{$file};
533     }
534
535     say $new "cpan/$pkg_dir/$_" for @commit;
536
537     close $new or die "Can't close $MANIFEST: $!\n";
538
539     system $^X => "Porting/manisort", '--quiet', "--output=$MANIFEST", $MANIFEST_NEW;
540     unlink $MANIFEST_NEW
541         or die "Can't delete temporary $MANIFEST_NEW: $!\n";
542 }
543
544
545 print "Running a make and saving its output to $MAKE_LOG ... ";
546 # Prepare for running (selected) tests
547 make 'test-prep';
548 print "done\n";
549
550 # The build system installs code from CPAN dists into the lib/ directory,
551 # creating directories as needed. This means that the cleaning-related rules
552 # in the Makefile need to know which directories to clean up. The Makefile
553 # is generated by Configure from Makefile.SH, so *that* file needs the list
554 # of directories. regen/lib_cleanup.pl is capable of automatically updating
555 # the contents of Makefile.SH (and win32/Makefile, which needs similar but
556 # not identical lists of directories), so we can just run that (using the
557 # newly-built Perl, as is done with the regen programs run by "make regen").
558 #
559 # We do this if any files at all have been added or deleted, regardless of
560 # whether those changes result in any directories being added or deleted,
561 # because the alternative would be to replicate the regen/lib_cleanup.pl
562 # logic here. That's fine, because regen/lib_cleanup.pl is idempotent if run
563 # repeatedly.
564 if (@commit || @gone) {
565     say "Running regen/lib_cleanup.pl to handle potential added/deleted dirs";
566     my $exe_dir = WIN32 ? ".\\" : './';
567     system "${exe_dir}perl$Config{_exe}", "-Ilib", "regen/lib_cleanup.pl"
568         and die "regen/lib_cleanup.pl failed\n";
569 }
570
571 #
572 # Must clean up, or else t/porting/FindExt.t will fail.
573 # Note that we can always retrieve the original directory with a git checkout.
574 #
575 print "About to clean up; hit return or abort (^C) "; <STDIN>;
576
577 remove_tree( "cpan/$old_dir" );
578 unlink "cpan/$new_file" unless $tarball;
579
580 #
581 # Run the tests. First the test belonging to the module, followed by the
582 # the tests in t/porting
583 #
584 chdir "t";
585 say "Running module tests";
586 my @test_files = grep { /\.t$/ } find_type_f( "../cpan/$pkg_dir" );
587 my $exe_dir = WIN32 ? "..\\" : './';
588 my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`;
589 unless ($output =~ /All tests successful/) {
590     say $output;
591     exit 1;
592 }
593
594 print "Running tests in t/porting ";
595 my @tests = glob 'porting/*.t';
596 chomp @tests;
597 my @failed;
598 foreach my $t (@tests) {
599     my @not = grep {!/# TODO/ }
600               grep { /^not/ }
601               `${exe_dir}perl -I../lib -I.. $t`;
602     print @not ? '!' : '.';
603     push @failed => $t if @not;
604 }
605 print "\n";
606 say "Failed tests: @failed" if @failed;
607
608
609 chdir '..';
610
611 open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
612 open my $new_Maintainers_pl, '>', 'Maintainers.pl';
613
614 my $found;
615 my $in_mod_section;
616 while (<$Maintainers_pl>) {
617     if (!$found) {
618         if ($in_mod_section) {
619             if (/DISTRIBUTION/) {
620                 if (s/\Q$old_version/$new_version/) {
621                     $found = 1;
622                 }
623             }
624
625             if (/^    \}/) {
626                 $in_mod_section = 0;
627             }
628         }
629
630         if (/\Q$module/) {
631             $in_mod_section = 1;
632         }
633     }
634
635     print $new_Maintainers_pl $_;
636 }
637
638 if ($found) {
639     say "Successfully updated Maintainers.pl";
640     unlink 'Porting/Maintainers.pl';
641     rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
642     chmod 0755 => 'Porting/Maintainers.pl';
643 }
644 else {
645     say "Could not update Porting/Maintainers.pl.";
646     say "Make sure you update this by hand before committing.";
647 }
648
649 print <<"EOF";
650
651 =======================================================================
652
653 $o_module is now at version $new_version
654 Next, you should run a "make test".
655
656 Hopefully that will complete successfully, but if not, you can make any
657 changes you need to get the tests to pass. Don't forget that you'll need
658 a "CUSTOMIZED" entry in Porting/Maintainers.pl if you change any of the
659 files under cpan/$pkg_dir.
660
661 Once all tests pass, you can "git add -u" and "git commit" the changes.
662
663 EOF
664
665 __END__