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
CommitLineData
33e80a47 1#!/usr/bin/env perl
418f4069 2
c5e3e317
JL
3=head1 NAME
4
f703fc96 5Porting/sync-with-cpan - Synchronize with CPAN distributions
c5e3e317
JL
6
7=head1 SYNOPSIS
8
0b2c8fe5
JK
9 sh ./Configure
10 perl Porting/sync-with-cpan <module>
c5e3e317
JL
11
12where <module> is the name it appears in the C<%Modules> hash
13of F<Porting/Maintainers.pl>
14
15=head1 DESCRIPTION
16
17Script to help out with syncing cpan distros.
18
19Does the following:
20
21=over 4
22
23=item *
24
25Fetches the package list from CPAN. Finds the current version of the given
26package. [1]
27
28=item *
29
30Downloads the relevant tarball; unpacks the tarball. [1]
31
32=item *
33
34Clean out the old directory (C<git clean -dfx>)
35
36=item *
37
38Moves the old directory out of the way, moves the new directory in place.
39
40=item *
41
42Restores any F<.gitignore> file.
43
44=item *
45
46Removes files from C<@IGNORE> and C<EXCLUDED>
47
48=item *
49
50C<git add> any new files.
51
52=item *
53
54C<git rm> any files that are gone.
55
56=item *
57
58Remove the +x bit on files in F<t/>
59
60=item *
61
62Remove the +x bit on files that don't have it enabled in the current dir
63
64=item *
65
66Restore files mentioned in C<CUSTOMIZED>
67
68=item *
69
190c1b3b 70Updates the contents of F<MANIFEST>
c5e3e317
JL
71
72=item *
73
74Runs a C<make> (assumes a configure has been run)
75
76=item *
77
78Cleans up
79
80=item *
81
82Runs tests for the package
83
84=item *
85
86Runs the porting tests
87
88=back
89
90[1] If the C<--tarball> option is given, then CPAN is not consulted.
91C<--tarball> should be the path to the tarball; the version is extracted
92from the filename -- but can be overwritten by the C<--version> option.
93
b7078f1e
AC
94=head1 OPTIONS
95
96=over 4
97
98=item C<--jobs> I<N>
99
100When running C<make>, pass a C<< -jI<N> >> option to it.
101
102=back
103
c5e3e317
JL
104=head1 TODO
105
106=over 4
107
108=item *
109
c5e3e317
JL
110Update F<Porting/Maintainers.pl>
111
112=item *
113
114Optional, run a full test suite
115
116=item *
117
118Handle complicated C<FILES>
119
120=back
121
122This is an initial version; no attempt has been made yet to make this
123portable. It shells out instead of trying to find a Perl solution.
cd9a1714 124In particular, it assumes git, perl, and make
c5e3e317
JL
125to be available.
126
127=cut
128
418f4069 129
4d18e0a2
A
130package Maintainers;
131
418f4069
A
132use 5.010;
133
134use strict;
135use warnings;
4d18e0a2 136use Getopt::Long;
a1450e8b 137use Archive::Tar;
bd4de633 138use File::Basename qw( basename );
192f56b0 139use File::Path qw( remove_tree );
fc134225 140use File::Find;
84709797 141use File::Spec::Functions qw( tmpdir rel2abs );
160daab8 142use Config qw( %Config );
418f4069
A
143
144$| = 1;
145
215d9c65
AC
146use constant WIN32 => $^O eq 'MSWin32';
147
07a826df 148die "This does not look like a top level directory"
418f4069
A
149 unless -d "cpan" && -d "Porting";
150
4b760246
AC
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.
154die "Please run Configure before using $0\n"
155 if !WIN32 && !-f "Makefile";
156
418f4069
A
157our @IGNORABLE;
158our %Modules;
159
160use autodie;
161
b27c755c 162require "./Porting/Maintainers.pl";
418f4069 163
e6e4cae9
AC
164my $MAKE_LOG = 'make.log';
165
418f4069
A
166my %IGNORABLE = map {$_ => 1} @IGNORABLE;
167
af8c53c3 168my $tmpdir = tmpdir();
fc134225 169
418f4069
A
170my $package = "02packages.details.txt";
171my $package_url = "http://www.cpan.org/modules/$package";
fc134225 172my $package_file = "$tmpdir/$package"; # this is a cache
418f4069 173
b7e2b692
JL
174my @problematic = (
175 'podlators', # weird CUSTOMIZED section due to .PL files
176);
177
418f4069 178
311454c0
MB
179sub usage
180{
181 my $err = shift and select STDERR;
182 print "Usage: $0 module [args] [cpan package]\n";
183 exit $err;
184}
185
4d18e0a2 186GetOptions ('tarball=s' => \my $tarball,
b5bf278a 187 'version=s' => \my $version,
b7078f1e 188 'jobs=i' => \my $make_jobs,
311454c0
MB
189 force => \my $force,
190 help => sub { usage 0; },
191 ) or die "Failed to parse arguments";
4d18e0a2 192
311454c0 193usage 1 unless @ARGV == 1 || @ARGV == 2;
418f4069 194
fc134225
MM
195sub 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
cd9a1714
MM
205# Equivalent of `chmod a-x`
206sub de_exec {
746bc9e1
AC
207 my ($filename) = @_;
208 my $mode = (stat $filename)[2] & 0777;
209 if ($mode & 0111) { # exec-bit set
210 chmod $mode & 0666, $filename;
cd9a1714
MM
211 }
212}
213
b6574671
AC
214# Equivalent of `chmod +w`
215sub 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
cd9a1714 223sub make {
160daab8 224 my @args= @_;
b7078f1e 225 unshift @args, "-j$make_jobs" if defined $make_jobs;
215d9c65 226 if (WIN32) {
160daab8 227 chdir "Win32";
e6e4cae9
AC
228 system "$Config{make} @args> ..\\$MAKE_LOG 2>&1"
229 and die "Running make failed, see $MAKE_LOG";
160daab8
MM
230 chdir '..';
231 } else {
e6e4cae9
AC
232 system "$Config{make} @args> $MAKE_LOG 2>&1"
233 and die "Running make failed, see $MAKE_LOG";
160daab8
MM
234 };
235};
236
5b73aae5 237my ($module) = shift;
418f4069 238
24c7e242
AC
239my $info = $Modules{$module};
240if (!$info) {
469f7948
AC
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";
246Cannot find module $module.
247The available options are listed in the %Modules hash in Porting/Maintainers.pl
248EOF
24c7e242
AC
249 say "Guessing you meant $guess instead of $module";
250 $module = $guess;
251}
252
7035e4d3
AC
253if ($info->{CUSTOMIZED}) {
254 print <<"EOF";
255$module has a CUSTOMIZED entry in Porting/Maintainers.pl.
256
257This program's behaviour is to copy every CUSTOMIZED file into the version
258of the module being imported. But that might not be the right thing: in some
259cases, the new CPAN version will supersede whatever changes had previously
260been made in blead, so it would be better to import the new CPAN files.
261
262If you've checked that the CUSTOMIZED versions are still correct, you can
263proceed now. Otherwise, you should abort and investigate the situation. If
264the blead customizations are no longer needed, delete the CUSTOMIZED entry
265for $module in Porting/Maintainers.pl (and you'll also need to regenerate
266t/porting/customized.dat in that case; see t/porting/customized.t).
267
268EOF
269 print "Hit return to continue; ^C to abort "; <STDIN>;
270}
271
24c7e242 272my $cpan_mod = @ARGV ? shift : $module;
4d18e0a2 273
418f4069 274my $distribution = $$info {DISTRIBUTION};
b5bf278a
A
275
276my @files = glob $$info {FILES};
b7e2b692 277if (!-d $files [0] || grep { $_ eq $module } @problematic) {
b5bf278a
A
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
84709797
FC
286use Cwd 'cwd';
287my $orig_pwd = cwd();
b5bf278a
A
288
289chdir "cpan";
290
83d3dd1d 291my $pkg_dir = $files[0];
418f4069
A
292 $pkg_dir =~ s!.*/!!;
293
87a7cbad 294my ($old_version) = $distribution =~ /-([0-9.]+(?:-TRIAL[0-9]*)?)\.tar\.gz/;
418f4069
A
295
296my $o_module = $module;
5b73aae5
A
297if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
298 $cpan_mod =~ s/-/::/g;
418f4069
A
299}
300
fea97686
FC
301sub 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
418f4069
A
317#
318# Find the information from CPAN.
319#
4d18e0a2
A
320my $new_file;
321my $new_version;
d11e2991 322if (defined $tarball) {
84709797 323 $tarball = rel2abs( $tarball, $orig_pwd ) ;
861c6796
AC
324 die "Tarball $tarball does not exist\n" if !-e $tarball;
325 die "Tarball $tarball is not a plain file\n" if !-f _;
d11e2991
AC
326 $new_file = $tarball;
327 $new_version = $version // ($new_file =~ /-([0-9._]+(?:-TRIAL[0-9]*)?)\.tar\.gz/) [0];
08ee4cf2
AC
328 die "Blead and that tarball both have version $new_version of $module\n"
329 if $new_version eq $old_version;
d11e2991
AC
330}
331else {
4d18e0a2
A
332 #
333 # Poor man's cache
334 #
335 unless (-f $package_file && -M $package_file < 1) {
fea97686 336 wget $package_url, $package_file;
4d18e0a2
A
337 }
338
cefd15c2
MM
339 open my $fh, '<', $package_file;
340 (my $new_line) = grep {/^$cpan_mod/} <$fh> # Yes, this needs a lot of memory
4d18e0a2 341 or die "Cannot find $cpan_mod on CPAN\n";
4d18e0a2 342 (undef, $new_version, my $new_path) = split ' ', $new_line;
3a4316cc
JL
343 if (defined $version) {
344 $new_path =~ s/-$new_version\./-$version\./;
345 $new_version = $version;
346 }
4d18e0a2
A
347 $new_file = (split '/', $new_path) [-1];
348
08ee4cf2
AC
349 die "The latest version of $module is $new_version, but blead already has it\n"
350 if $new_version eq $old_version;
351
499e37eb 352 my $url = "https://cpan.metacpan.org/authors/id/$new_path";
4d18e0a2
A
353 say "Fetching $url";
354 #
355 # Fetch the new distro
356 #
fea97686 357 wget $url, $new_file;
4d18e0a2 358}
418f4069
A
359
360my $old_dir = "$pkg_dir-$old_version";
418f4069
A
361
362say "Cleaning out old directory";
363system git => 'clean', '-dfxq', $pkg_dir;
364
418f4069 365say "Unpacking $new_file";
5fb91d48 366Archive::Tar->extract_archive( $new_file );
418f4069 367
bd4de633 368(my $new_dir = basename($new_file)) =~ s/\.tar\.gz//;
3f7808eb 369# ensure 'make' will update all files
fc134225
MM
370my $t= time;
371for my $file (find_type_f($new_dir)) {
b6574671 372 make_writable($file); # for convenience if the user later edits it
fc134225
MM
373 utime($t,$t,$file);
374};
418f4069
A
375
376say "Renaming directories";
377rename $pkg_dir => $old_dir;
418f4069 378
83d3dd1d
JL
379say "Creating new package directory";
380mkdir $pkg_dir;
381
382say "Populating new package directory";
383my $map = $$info {MAP};
384my @EXCLUDED_QR;
385my %EXCLUDED_QQ;
386if ($$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
fc134225 393FILE: for my $file ( find_type_f( $new_dir )) {
83d3dd1d
JL
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 }
7bbb137d
JL
408 else {
409 $file = $files[0] . '/' . $file;
410 }
83d3dd1d
JL
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}
192f56b0 430remove_tree( $new_dir );
418f4069
A
431
432if (-f "$old_dir/.gitignore") {
433 say "Restoring .gitignore";
434 system git => 'checkout', "$pkg_dir/.gitignore";
435}
436
fc134225 437my @new_files = find_type_f( $pkg_dir );
418f4069
A
438@new_files = grep {$_ ne $pkg_dir} @new_files;
439s!^[^/]+/!! for @new_files;
440my %new_files = map {$_ => 1} @new_files;
441
fc134225 442my @old_files = find_type_f( $old_dir );
418f4069
A
443@old_files = grep {$_ ne $old_dir} @old_files;
444s!^[^/]+/!! for @old_files;
445my %old_files = map {$_ => 1} @old_files;
446
418f4069
A
447my @delete;
448my @commit;
449my @gone;
418f4069
A
450FILE:
451foreach 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 }
418f4069
A
458 push @commit => $file;
459}
460foreach my $file (@old_files) {
461 next if -d "$old_dir/$file";
462 next if $new_files {$file};
463 push @gone => $file;
464}
ad9b4e6f
A
465
466#
467# Find all files with an exec bit
468#
fc134225 469my @exec = find_type_f( $pkg_dir );
ad9b4e6f
A
470my @de_exec;
471foreach 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}
418f4069
A
486
487#
488# No need to change the +x bit on files that will be deleted.
489#
ad9b4e6f 490if (@de_exec && @delete) {
a9f5d1d4 491 my %delete = map {+"$pkg_dir/$_" => 1} @delete;
ad9b4e6f 492 @de_exec = grep {!$delete {$_}} @de_exec;
418f4069
A
493}
494
e42bf9ad
AC
495#
496# Mustn't change the +x bit on files that are whitelisted
497#
498if (@de_exec) {
54ed4dc4 499 my %permitted = map { (my $x = $_) =~ tr/\n//d; $x => 1 } grep !/^#/,
e42bf9ad
AC
500 do { local @ARGV = '../Porting/exec-bit.txt'; <> };
501 @de_exec = grep !$permitted{"cpan/$pkg_dir/$_"}, @de_exec;
502}
503
418f4069
A
504say "unlink $pkg_dir/$_" for @delete;
505say "git add $pkg_dir/$_" for @commit;
506say "git rm -f $pkg_dir/$_" for @gone;
ad9b4e6f 507say "chmod a-x $pkg_dir/$_" for @de_exec;
418f4069
A
508
509print "Hit return to continue; ^C to abort "; <STDIN>;
510
511unlink "$pkg_dir/$_" for @delete;
512system git => 'add', "$pkg_dir/$_" for @commit;
513system git => 'rm', '-f', "$pkg_dir/$_" for @gone;
cd9a1714 514de_exec( "$pkg_dir/$_" ) for @de_exec;
418f4069 515
9c259538
A
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#
521if ($$info {CUSTOMIZED}) {
522 say "Restoring customized files";
523 foreach my $file (@{$$info {CUSTOMIZED}}) {
524 system git => "checkout", "$pkg_dir/$file";
525 }
526}
527
a8121781 528chdir "..";
190c1b3b 529if (@commit || @gone) {
418f4069 530 say "Fixing MANIFEST";
190c1b3b
AC
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";
418f4069
A
552}
553
554
e6e4cae9 555print "Running a make and saving its output to $MAKE_LOG ... ";
160daab8
MM
556# Prepare for running (selected) tests
557make 'test-prep';
418f4069
A
558print "done\n";
559
d8a823f4
AC
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.
574if (@commit || @gone) {
575 say "Running regen/lib_cleanup.pl to handle potential added/deleted dirs";
215d9c65 576 my $exe_dir = WIN32 ? ".\\" : './';
d8a823f4
AC
577 system "${exe_dir}perl$Config{_exe}", "-Ilib", "regen/lib_cleanup.pl"
578 and die "regen/lib_cleanup.pl failed\n";
579}
580
418f4069
A
581#
582# Must clean up, or else t/porting/FindExt.t will fail.
730ad6b9 583# Note that we can always retrieve the original directory with a git checkout.
418f4069
A
584#
585print "About to clean up; hit return or abort (^C) "; <STDIN>;
586
192f56b0
MM
587remove_tree( "cpan/$old_dir" );
588unlink "cpan/$new_file" unless $tarball;
418f4069 589
ad9b4e6f
A
590#
591# Run the tests. First the test belonging to the module, followed by the
592# the tests in t/porting
593#
192f56b0 594chdir "t";
ad9b4e6f 595say "Running module tests";
57b5d6e1 596my @test_files = grep { /\.t$/ } find_type_f( "../cpan/$pkg_dir" );
215d9c65 597my $exe_dir = WIN32 ? "..\\" : './';
60f5272c 598my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`;
ad9b4e6f
A
599unless ($output =~ /All tests successful/) {
600 say $output;
601 exit 1;
602}
603
418f4069 604print "Running tests in t/porting ";
fc134225 605my @tests = glob 'porting/*.t';
418f4069
A
606chomp @tests;
607my @failed;
608foreach my $t (@tests) {
cefd15c2
MM
609 my @not = grep {!/# TODO/ }
610 grep { /^not/ }
611 `${exe_dir}perl -I../lib -I.. $t`;
418f4069
A
612 print @not ? '!' : '.';
613 push @failed => $t if @not;
614}
615print "\n";
616say "Failed tests: @failed" if @failed;
617
618
9807c17b
JL
619chdir '..';
620
621open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
622open my $new_Maintainers_pl, '>', 'Maintainers.pl';
623
624my $found;
625my $in_mod_section;
626while (<$Maintainers_pl>) {
627 if (!$found) {
628 if ($in_mod_section) {
629 if (/DISTRIBUTION/) {
33c6567b 630 if (s/\Q$old_version/$new_version/) {
9807c17b
JL
631 $found = 1;
632 }
633 }
634
92e8e650 635 if (/^ \}/) {
9807c17b
JL
636 $in_mod_section = 0;
637 }
638 }
639
ec1d1ba0 640 if (/\Q$module/) {
9807c17b
JL
641 $in_mod_section = 1;
642 }
643 }
644
645 print $new_Maintainers_pl $_;
646}
647
648if ($found) {
d9d83ea5 649 say "Successfully updated Maintainers.pl";
9807c17b
JL
650 unlink 'Porting/Maintainers.pl';
651 rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
cd9a1714 652 chmod 0755 => 'Porting/Maintainers.pl';
9807c17b
JL
653}
654else {
655 say "Could not update Porting/Maintainers.pl.";
656 say "Make sure you update this by hand before committing.";
657}
418f4069 658
592f3827 659print <<"EOF";
418f4069 660
592f3827
AC
661=======================================================================
662
663$o_module is now at version $new_version
664Next, you should run a "make test".
665
666Hopefully that will complete successfully, but if not, you can make any
667changes you need to get the tests to pass. Don't forget that you'll need
668a "CUSTOMIZED" entry in Porting/Maintainers.pl if you change any of the
669files under cpan/$pkg_dir.
670
671Once all tests pass, you can "git add -u" and "git commit" the changes.
672
673EOF
418f4069
A
674
675__END__