final commit for v5.24.0!
[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 Adds new files to 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 TODO
94
95 =over 4
96
97 =item *
98
99 Delete files from F<MANIFEST>
100
101 =item *
102
103 Update F<Porting/Maintainers.pl>
104
105 =item *
106
107 Optional, run a full test suite
108
109 =item *
110
111 Handle complicated C<FILES>
112
113 =back
114
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
118 to be available.
119
120 =cut
121
122
123 package Maintainers;
124
125 use 5.010;
126
127 use strict;
128 use warnings;
129 use Getopt::Long;
130 use Archive::Tar;
131 use File::Path qw( remove_tree );
132 use File::Find;
133 use Config qw( %Config );
134
135 $| = 1;
136
137 die "This does not look like a top level directory"
138      unless -d "cpan" && -d "Porting";
139
140 our @IGNORABLE;
141 our %Modules;
142
143 use autodie;
144
145 require "Porting/Maintainers.pl";
146
147 my %IGNORABLE    = map {$_ => 1} @IGNORABLE;
148
149 my $tmpdir= $ENV{ TEMP } // '/tmp';
150
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
154
155 my @problematic = (
156     'podlators', # weird CUSTOMIZED section due to .PL files
157 );
158
159
160 sub usage
161 {
162     my $err = shift and select STDERR;
163     print "Usage: $0 module [args] [cpan package]\n";
164     exit $err;
165 }
166
167 GetOptions ('tarball=s'  =>  \my $tarball,
168             'version=s'  =>  \my $version,
169              force       =>  \my $force,
170              help        =>  sub { usage 0; },
171              ) or  die "Failed to parse arguments";
172
173 usage 1 unless @ARGV == 1 || @ARGV == 2;
174
175 sub find_type_f {
176     my @res;
177     find( { no_chdir => 1, wanted => sub {
178         my $file= $File::Find::name;
179         return unless -f $file;
180         push @res, $file
181     }}, @_ );
182     @res
183 };
184
185 # Equivalent of `chmod a-x`
186 sub de_exec {
187     for my $filename ( @_ ) {
188         my $mode= (stat $filename)[2] & 0777;
189         if( $mode & 0111 ) { # exec-bit set
190             chmod $mode & 0666, $filename;
191         };
192     }
193 }
194
195 sub make {
196     my @args= @_;
197     if( $^O eq 'MSWin32') {
198         chdir "Win32";
199         system "$Config{make} @args> ..\\make.log 2>&1" and die "Running make failed, see make.log";
200         chdir '..';
201     } else {
202         system "$Config{make} @args> make.log 2>&1" and die "Running make failed, see make.log";
203     };
204 };
205
206 my ($module)  = shift;
207 my  $cpan_mod = @ARGV ? shift : $module;
208
209
210 my  $info         = $Modules {$module} or die "Cannot find module $module";
211 my  $distribution = $$info {DISTRIBUTION};
212
213 my @files         = glob $$info {FILES};
214 if (!-d $files [0] || grep { $_ eq $module } @problematic) {
215     say "This looks like a setup $0 cannot handle (yet)";
216     unless ($force) {
217         say "Will not continue without a --force option";
218         exit 1;
219     }
220     say "--force is in effect, so we'll soldier on. Wish me luck!";
221 }
222
223
224 chdir "cpan";
225
226 my  $pkg_dir      = $files[0];
227     $pkg_dir      =~ s!.*/!!;
228
229 my ($old_version) = $distribution =~ /-([0-9.]+(?:-TRIAL[0-9]*)?)\.tar\.gz/;
230
231 my  $o_module     = $module;
232 if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
233     $cpan_mod =~ s/-/::/g;
234 }
235
236 #
237 # Find the information from CPAN.
238 #
239 my $new_file;
240 my $new_version;
241 unless ($tarball) {
242     #
243     # Poor man's cache
244     #
245     unless (-f $package_file && -M $package_file < 1) {
246         eval {
247             require HTTP::Tiny;
248             my $http= HTTP::Tiny->new();
249             $http->mirror( $package_url => $package_file );
250             1
251         } or system wget => $package_url, '-qO', $package_file;
252     }
253
254     open my $fh, '<', $package_file;
255     (my $new_line) = grep {/^$cpan_mod/} <$fh> # Yes, this needs a lot of memory
256                      or die "Cannot find $cpan_mod on CPAN\n";
257     (undef, $new_version, my $new_path) = split ' ', $new_line;
258     if (defined $version) {
259         $new_path =~ s/-$new_version\./-$version\./;
260         $new_version = $version;
261     }
262     $new_file = (split '/', $new_path) [-1];
263
264     my $url = "http://search.cpan.org/CPAN/authors/id/$new_path";
265     say "Fetching $url";
266     #
267     # Fetch the new distro
268     #
269     eval {
270         require HTTP::Tiny;
271         my $http= HTTP::Tiny->new();
272         $http->mirror( $url => $new_file );
273         1
274     } or system wget => $url, '-qO', $new_file;
275 }
276 else {
277     $new_file     = $tarball;
278     $new_version  = $version // ($new_file =~ /-([0-9._]+(?:-TRIAL[0-9]*)?)\.tar\.gz/) [0];
279 }
280
281 my  $old_dir      = "$pkg_dir-$old_version";
282
283 say "Cleaning out old directory";
284 system git => 'clean', '-dfxq', $pkg_dir;
285
286 say "Unpacking $new_file";
287 Archive::Tar->extract_archive( $new_file );
288
289 (my $new_dir = $new_file) =~ s/\.tar\.gz//;
290 # ensure 'make' will update all files
291 my $t= time;
292 for my $file (find_type_f($new_dir)) {
293     open(my $fh,">>$file") || die "Cannot write $file:$!";
294     close($fh);
295     utime($t,$t,$file);
296 };
297
298 say "Renaming directories";
299 rename $pkg_dir => $old_dir;
300
301 say "Creating new package directory";
302 mkdir $pkg_dir;
303
304 say "Populating new package directory";
305 my $map = $$info {MAP};
306 my @EXCLUDED_QR;
307 my %EXCLUDED_QQ;
308 if ($$info {EXCLUDED}) {
309     foreach my $entry (@{$$info {EXCLUDED}}) {
310         if (ref $entry) {push @EXCLUDED_QR => $entry}
311         else            {$EXCLUDED_QQ {$entry} = 1}
312     }
313 }
314
315 FILE: for my $file ( find_type_f( $new_dir )) {
316     my $old_file = $file;
317     $file =~ s{^$new_dir/}{};
318
319     next if $EXCLUDED_QQ{$file};
320     for my $qr (@EXCLUDED_QR) {
321         next FILE if $file =~ $qr;
322     }
323
324     if ( $map ) {
325         for my $key ( sort { length $b <=> length $a } keys %$map ) {
326             my $val = $map->{$key};
327             last if $file =~ s/^$key/$val/;
328         }
329     }
330     else {
331         $file = $files[0] . '/' . $file;
332     }
333
334     if ( $file =~ m{^cpan/} ) {
335         $file =~ s{^cpan/}{};
336     }
337     else {
338         $file = '../' . $file;
339     }
340
341     my $prefix = '';
342     my @parts = split '/', $file;
343     pop @parts;
344     for my $part (@parts) {
345         $prefix .= '/' if $prefix;
346         $prefix .= $part;
347         mkdir $prefix unless -d $prefix;
348     }
349
350     rename $old_file => $file;
351 }
352 remove_tree( $new_dir );
353
354 if (-f "$old_dir/.gitignore") {
355     say "Restoring .gitignore";
356     system git => 'checkout', "$pkg_dir/.gitignore";
357 }
358
359 my @new_files = find_type_f( $pkg_dir );
360 @new_files = grep {$_ ne $pkg_dir} @new_files;
361 s!^[^/]+/!! for @new_files;
362 my %new_files = map {$_ => 1} @new_files;
363
364 my @old_files = find_type_f( $old_dir );
365 @old_files = grep {$_ ne $old_dir} @old_files;
366 s!^[^/]+/!! for @old_files;
367 my %old_files = map {$_ => 1} @old_files;
368
369 my @delete;
370 my @commit;
371 my @gone;
372 FILE:
373 foreach my $file (@new_files) {
374     next if -d "$pkg_dir/$file";   # Ignore directories.
375     next if $old_files {$file};    # It's already there.
376     if ($IGNORABLE {$file}) {
377         push @delete => $file;
378         next;
379     }
380     push @commit => $file;
381 }
382 foreach my $file (@old_files) {
383     next if -d "$old_dir/$file";
384     next if $new_files {$file};
385     push @gone => $file;
386 }
387
388 #
389 # Find all files with an exec bit
390 #
391 my @exec = find_type_f( $pkg_dir );
392 my @de_exec;
393 foreach my $file (@exec) {
394     # Remove leading dir
395     $file =~ s!^[^/]+/!!;
396     if ($file =~ m!^t/!) {
397         push @de_exec => $file;
398         next;
399     }
400     # Check to see if the file exists; if it doesn't and doesn't have
401     # the exec bit, remove it.
402     if ($old_files {$file}) {
403         unless (-x "$old_dir/$file") {
404             push @de_exec => $file;
405         }
406     }
407 }
408
409 #
410 # No need to change the +x bit on files that will be deleted.
411 #
412 if (@de_exec && @delete) {
413     my %delete = map {+"$pkg_dir/$_" => 1} @delete;
414     @de_exec = grep {!$delete {$_}} @de_exec;
415 }
416
417 say "unlink $pkg_dir/$_" for @delete;
418 say "git add $pkg_dir/$_" for @commit;
419 say "git rm -f $pkg_dir/$_" for @gone;
420 say "chmod a-x $pkg_dir/$_" for @de_exec;
421
422 print "Hit return to continue; ^C to abort "; <STDIN>;
423
424 unlink "$pkg_dir/$_"                      for @delete;
425 system git   => 'add', "$pkg_dir/$_"      for @commit;
426 system git   => 'rm', '-f', "$pkg_dir/$_" for @gone;
427 de_exec( "$pkg_dir/$_" )                  for @de_exec;
428
429 #
430 # Restore anything that is customized.
431 # We don't really care whether we've deleted the file - since we
432 # do a git restore, it's going to be resurrected if necessary.
433 #
434 if ($$info {CUSTOMIZED}) {
435     say "Restoring customized files";
436     foreach my $file (@{$$info {CUSTOMIZED}}) {
437         system git => "checkout", "$pkg_dir/$file";
438     }
439 }
440
441 chdir "..";
442 if (@commit) {
443     say "Fixing MANIFEST";
444     my $MANIFEST      = "MANIFEST";
445     my $MANIFEST_SORT = "$MANIFEST.sorted";
446     open my $fh, ">>", $MANIFEST;
447     say $fh "cpan/$pkg_dir/$_" for @commit;
448     close $fh;
449     system perl => "Porting/manisort", '--output', $MANIFEST_SORT;
450     rename $MANIFEST_SORT => $MANIFEST;
451 }
452
453
454 print "Running a make ... ";
455 # Prepare for running (selected) tests
456 make 'test-prep';
457 print "done\n";
458
459 #
460 # Must clean up, or else t/porting/FindExt.t will fail.
461 # Note that we can always retrieve the original directory with a git checkout.
462 #
463 print "About to clean up; hit return or abort (^C) "; <STDIN>;
464
465 remove_tree( "cpan/$old_dir" );
466 unlink "cpan/$new_file" unless $tarball;
467
468 #
469 # Run the tests. First the test belonging to the module, followed by the
470 # the tests in t/porting
471 #
472 chdir "t";
473 say "Running module tests";
474 my @test_files = grep { /\.t$/ } find_type_f( $pkg_dir );
475 my $exe_dir= $^O =~ /MSWin/ ? "..\\" : './';
476 my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`;
477 unless ($output =~ /All tests successful/) {
478     say $output;
479     exit 1;
480 }
481
482 print "Running tests in t/porting ";
483 my @tests = glob 'porting/*.t';
484 chomp @tests;
485 my @failed;
486 foreach my $t (@tests) {
487     my @not = grep {!/# TODO/ }
488               grep { /^not/ }
489               `${exe_dir}perl -I../lib -I.. $t`;
490     print @not ? '!' : '.';
491     push @failed => $t if @not;
492 }
493 print "\n";
494 say "Failed tests: @failed" if @failed;
495
496
497 say "Attempting to update Maintainers.pl";
498 chdir '..';
499
500 open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
501 open my $new_Maintainers_pl, '>', 'Maintainers.pl';
502
503 my $found;
504 my $in_mod_section;
505 while (<$Maintainers_pl>) {
506     if (!$found) {
507         if ($in_mod_section) {
508             if (/DISTRIBUTION/) {
509                 if (s/\Q$old_version/$new_version/) {
510                     $found = 1;
511                 }
512             }
513
514             if (/^    }/) {
515                 $in_mod_section = 0;
516             }
517         }
518
519         if (/\Q$cpan_mod/) {
520             $in_mod_section = 1;
521         }
522     }
523
524     print $new_Maintainers_pl $_;
525 }
526
527 if ($found) {
528     unlink 'Porting/Maintainers.pl';
529     rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
530     chmod 0755 => 'Porting/Maintainers.pl';
531 }
532 else {
533     say "Could not update Porting/Maintainers.pl.";
534     say "Make sure you update this by hand before committing.";
535 }
536
537 say "$o_module is now version $new_version";
538 say "Now you ought to run a make; make test ...";
539
540
541 __END__