This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Elide use of `grep`
[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
9 perl Porting/sync-with-cpan <module>
10
11where <module> is the name it appears in the C<%Modules> hash
12of F<Porting/Maintainers.pl>
13
14=head1 DESCRIPTION
15
16Script to help out with syncing cpan distros.
17
18Does the following:
19
20=over 4
21
22=item *
23
24Fetches the package list from CPAN. Finds the current version of the given
25package. [1]
26
27=item *
28
29Downloads the relevant tarball; unpacks the tarball. [1]
30
31=item *
32
33Clean out the old directory (C<git clean -dfx>)
34
35=item *
36
37Moves the old directory out of the way, moves the new directory in place.
38
39=item *
40
41Restores any F<.gitignore> file.
42
43=item *
44
45Removes files from C<@IGNORE> and C<EXCLUDED>
46
47=item *
48
49C<git add> any new files.
50
51=item *
52
53C<git rm> any files that are gone.
54
55=item *
56
57Remove the +x bit on files in F<t/>
58
59=item *
60
61Remove the +x bit on files that don't have it enabled in the current dir
62
63=item *
64
65Restore files mentioned in C<CUSTOMIZED>
66
67=item *
68
69Adds new files to F<MANIFEST>
70
71=item *
72
73Runs a C<make> (assumes a configure has been run)
74
75=item *
76
77Cleans up
78
79=item *
80
81Runs tests for the package
82
83=item *
84
85Runs the porting tests
86
87=back
88
89[1] If the C<--tarball> option is given, then CPAN is not consulted.
90C<--tarball> should be the path to the tarball; the version is extracted
91from the filename -- but can be overwritten by the C<--version> option.
92
93=head1 TODO
94
95=over 4
96
97=item *
98
99Delete files from F<MANIFEST>
100
101=item *
102
103Update F<Porting/Maintainers.pl>
104
105=item *
106
107Optional, run a full test suite
108
109=item *
110
111Handle complicated C<FILES>
112
113=back
114
115This is an initial version; no attempt has been made yet to make this
116portable. It shells out instead of trying to find a Perl solution.
cd9a1714 117In particular, it assumes git, perl, and make
c5e3e317
JL
118to be available.
119
120=cut
121
418f4069 122
4d18e0a2
A
123package Maintainers;
124
418f4069
A
125use 5.010;
126
127use strict;
128use warnings;
4d18e0a2 129use Getopt::Long;
a1450e8b 130use Archive::Tar;
192f56b0 131use File::Path qw( remove_tree );
fc134225 132use File::Find;
160daab8 133use Config qw( %Config );
418f4069
A
134
135$| = 1;
136
07a826df 137die "This does not look like a top level directory"
418f4069
A
138 unless -d "cpan" && -d "Porting";
139
418f4069
A
140our @IGNORABLE;
141our %Modules;
142
143use autodie;
144
145require "Porting/Maintainers.pl";
146
418f4069
A
147my %IGNORABLE = map {$_ => 1} @IGNORABLE;
148
fc134225
MM
149my $tmpdir= $ENV{ TEMP } // '/tmp';
150
418f4069
A
151my $package = "02packages.details.txt";
152my $package_url = "http://www.cpan.org/modules/$package";
fc134225 153my $package_file = "$tmpdir/$package"; # this is a cache
418f4069 154
b7e2b692
JL
155my @problematic = (
156 'podlators', # weird CUSTOMIZED section due to .PL files
157);
158
418f4069 159
4d18e0a2 160GetOptions ('tarball=s' => \my $tarball,
b5bf278a
A
161 'version=s' => \my $version,
162 force => \my $force,)
4d18e0a2
A
163 or die "Failed to parse arguments";
164
165die "Usage: $0 module [args] [cpan package]" unless @ARGV == 1 || @ARGV == 2;
418f4069 166
fc134225
MM
167sub find_type_f {
168 my @res;
169 find( { no_chdir => 1, wanted => sub {
170 my $file= $File::Find::name;
171 return unless -f $file;
172 push @res, $file
173 }}, @_ );
174 @res
175};
176
cd9a1714
MM
177# Equivalent of `chmod a-x`
178sub de_exec {
179 for my $filename ( @_ ) {
180 my $mode= (stat $filename)[2] & 0777;
181 if( $mode & 0111 ) { # exec-bit set
182 chmod $mode & 0666, $filename;
183 };
184 }
185}
186
187sub make {
160daab8
MM
188 my @args= @_;
189 if( $^O eq 'MSWin32') {
190 chdir "Win32";
191 system "$Config{make} @args> ..\\make.log 2>&1" and die "Running make failed, see make.log";
192 chdir '..';
193 } else {
194 system "$Config{make} @args> make.log 2>&1" and die "Running make failed, see make.log";
195 };
196};
197
5b73aae5
A
198my ($module) = shift;
199my $cpan_mod = @ARGV ? shift : $module;
418f4069 200
4d18e0a2 201
418f4069
A
202my $info = $Modules {$module} or die "Cannot find module $module";
203my $distribution = $$info {DISTRIBUTION};
b5bf278a
A
204
205my @files = glob $$info {FILES};
b7e2b692 206if (!-d $files [0] || grep { $_ eq $module } @problematic) {
b5bf278a
A
207 say "This looks like a setup $0 cannot handle (yet)";
208 unless ($force) {
209 say "Will not continue without a --force option";
210 exit 1;
211 }
212 say "--force is in effect, so we'll soldier on. Wish me luck!";
213}
214
215
216chdir "cpan";
217
83d3dd1d 218my $pkg_dir = $files[0];
418f4069
A
219 $pkg_dir =~ s!.*/!!;
220
221my ($old_version) = $distribution =~ /-([0-9.]+)\.tar\.gz/;
222
223my $o_module = $module;
5b73aae5
A
224if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
225 $cpan_mod =~ s/-/::/g;
418f4069
A
226}
227
228#
229# Find the information from CPAN.
230#
4d18e0a2
A
231my $new_file;
232my $new_version;
233unless ($tarball) {
234 #
235 # Poor man's cache
236 #
237 unless (-f $package_file && -M $package_file < 1) {
132246f2
MM
238 eval {
239 require HTTP::Tiny;
240 my $http= HTTP::Tiny->new();
241 $http->mirror( $package_url => $package_file );
242 1
243 } or system wget => $package_url, '-qO', $package_file;
4d18e0a2
A
244 }
245
cefd15c2
MM
246 open my $fh, '<', $package_file;
247 (my $new_line) = grep {/^$cpan_mod/} <$fh> # Yes, this needs a lot of memory
4d18e0a2 248 or die "Cannot find $cpan_mod on CPAN\n";
4d18e0a2 249 (undef, $new_version, my $new_path) = split ' ', $new_line;
3a4316cc
JL
250 if (defined $version) {
251 $new_path =~ s/-$new_version\./-$version\./;
252 $new_version = $version;
253 }
4d18e0a2
A
254 $new_file = (split '/', $new_path) [-1];
255
256 my $url = "http://search.cpan.org/CPAN/authors/id/$new_path";
257 say "Fetching $url";
258 #
259 # Fetch the new distro
260 #
132246f2
MM
261 eval {
262 require HTTP::Tiny;
263 my $http= HTTP::Tiny->new();
264 $http->mirror( $url => $new_file );
265 1
266 } or system wget => $url, '-qO', $new_file;
4d18e0a2
A
267}
268else {
269 $new_file = $tarball;
270 $new_version = $version // ($new_file =~ /-([0-9._]+)\.tar\.gz/) [0];
271}
418f4069
A
272
273my $old_dir = "$pkg_dir-$old_version";
418f4069
A
274
275say "Cleaning out old directory";
276system git => 'clean', '-dfxq', $pkg_dir;
277
418f4069 278say "Unpacking $new_file";
5fb91d48 279Archive::Tar->extract_archive( $new_file );
418f4069 280
618ac2f6 281(my $new_dir = $new_file) =~ s/\.tar\.gz//;
3f7808eb 282# ensure 'make' will update all files
fc134225
MM
283my $t= time;
284for my $file (find_type_f($new_dir)) {
285 open(my $fh,">>$file") || die "Cannot write $file:$!";
286 close($fh);
287 utime($t,$t,$file);
288};
418f4069
A
289
290say "Renaming directories";
291rename $pkg_dir => $old_dir;
418f4069 292
83d3dd1d
JL
293say "Creating new package directory";
294mkdir $pkg_dir;
295
296say "Populating new package directory";
297my $map = $$info {MAP};
298my @EXCLUDED_QR;
299my %EXCLUDED_QQ;
300if ($$info {EXCLUDED}) {
301 foreach my $entry (@{$$info {EXCLUDED}}) {
302 if (ref $entry) {push @EXCLUDED_QR => $entry}
303 else {$EXCLUDED_QQ {$entry} = 1}
304 }
305}
306
fc134225 307FILE: for my $file ( find_type_f( $new_dir )) {
83d3dd1d
JL
308 my $old_file = $file;
309 $file =~ s{^$new_dir/}{};
310
311 next if $EXCLUDED_QQ{$file};
312 for my $qr (@EXCLUDED_QR) {
313 next FILE if $file =~ $qr;
314 }
315
316 if ( $map ) {
317 for my $key ( sort { length $b <=> length $a } keys %$map ) {
318 my $val = $map->{$key};
319 last if $file =~ s/^$key/$val/;
320 }
321 }
7bbb137d
JL
322 else {
323 $file = $files[0] . '/' . $file;
324 }
83d3dd1d
JL
325
326 if ( $file =~ m{^cpan/} ) {
327 $file =~ s{^cpan/}{};
328 }
329 else {
330 $file = '../' . $file;
331 }
332
333 my $prefix = '';
334 my @parts = split '/', $file;
335 pop @parts;
336 for my $part (@parts) {
337 $prefix .= '/' if $prefix;
338 $prefix .= $part;
339 mkdir $prefix unless -d $prefix;
340 }
341
342 rename $old_file => $file;
343}
192f56b0 344remove_tree( $new_dir );
418f4069
A
345
346if (-f "$old_dir/.gitignore") {
347 say "Restoring .gitignore";
348 system git => 'checkout', "$pkg_dir/.gitignore";
349}
350
fc134225 351my @new_files = find_type_f( $pkg_dir );
418f4069
A
352@new_files = grep {$_ ne $pkg_dir} @new_files;
353s!^[^/]+/!! for @new_files;
354my %new_files = map {$_ => 1} @new_files;
355
fc134225 356my @old_files = find_type_f( $old_dir );
418f4069
A
357@old_files = grep {$_ ne $old_dir} @old_files;
358s!^[^/]+/!! for @old_files;
359my %old_files = map {$_ => 1} @old_files;
360
418f4069
A
361my @delete;
362my @commit;
363my @gone;
418f4069
A
364FILE:
365foreach my $file (@new_files) {
366 next if -d "$pkg_dir/$file"; # Ignore directories.
367 next if $old_files {$file}; # It's already there.
368 if ($IGNORABLE {$file}) {
369 push @delete => $file;
370 next;
371 }
418f4069
A
372 push @commit => $file;
373}
374foreach my $file (@old_files) {
375 next if -d "$old_dir/$file";
376 next if $new_files {$file};
377 push @gone => $file;
378}
ad9b4e6f
A
379
380#
381# Find all files with an exec bit
382#
fc134225 383my @exec = find_type_f( $pkg_dir );
ad9b4e6f
A
384my @de_exec;
385foreach my $file (@exec) {
386 # Remove leading dir
387 $file =~ s!^[^/]+/!!;
388 if ($file =~ m!^t/!) {
389 push @de_exec => $file;
390 next;
391 }
392 # Check to see if the file exists; if it doesn't and doesn't have
393 # the exec bit, remove it.
394 if ($old_files {$file}) {
395 unless (-x "$old_dir/$file") {
396 push @de_exec => $file;
397 }
398 }
399}
418f4069
A
400
401#
402# No need to change the +x bit on files that will be deleted.
403#
ad9b4e6f 404if (@de_exec && @delete) {
a9f5d1d4 405 my %delete = map {+"$pkg_dir/$_" => 1} @delete;
ad9b4e6f 406 @de_exec = grep {!$delete {$_}} @de_exec;
418f4069
A
407}
408
409say "unlink $pkg_dir/$_" for @delete;
410say "git add $pkg_dir/$_" for @commit;
411say "git rm -f $pkg_dir/$_" for @gone;
ad9b4e6f 412say "chmod a-x $pkg_dir/$_" for @de_exec;
418f4069
A
413
414print "Hit return to continue; ^C to abort "; <STDIN>;
415
416unlink "$pkg_dir/$_" for @delete;
417system git => 'add', "$pkg_dir/$_" for @commit;
418system git => 'rm', '-f', "$pkg_dir/$_" for @gone;
cd9a1714 419de_exec( "$pkg_dir/$_" ) for @de_exec;
418f4069 420
9c259538
A
421#
422# Restore anything that is customized.
423# We don't really care whether we've deleted the file - since we
424# do a git restore, it's going to be resurrected if necessary.
425#
426if ($$info {CUSTOMIZED}) {
427 say "Restoring customized files";
428 foreach my $file (@{$$info {CUSTOMIZED}}) {
429 system git => "checkout", "$pkg_dir/$file";
430 }
431}
432
a8121781 433chdir "..";
418f4069
A
434if (@commit) {
435 say "Fixing MANIFEST";
a8121781 436 my $MANIFEST = "MANIFEST";
418f4069
A
437 my $MANIFEST_SORT = "$MANIFEST.sorted";
438 open my $fh, ">>", $MANIFEST;
a8121781 439 say $fh "cpan/$pkg_dir/$_" for @commit;
418f4069 440 close $fh;
a8121781 441 system perl => "Porting/manisort", '--output', $MANIFEST_SORT;
418f4069
A
442 rename $MANIFEST_SORT => $MANIFEST;
443}
444
445
418f4069 446print "Running a make ... ";
160daab8
MM
447# Prepare for running (selected) tests
448make 'test-prep';
418f4069
A
449print "done\n";
450
451#
452# Must clean up, or else t/porting/FindExt.t will fail.
730ad6b9 453# Note that we can always retrieve the original directory with a git checkout.
418f4069
A
454#
455print "About to clean up; hit return or abort (^C) "; <STDIN>;
456
192f56b0
MM
457remove_tree( "cpan/$old_dir" );
458unlink "cpan/$new_file" unless $tarball;
418f4069 459
ad9b4e6f
A
460#
461# Run the tests. First the test belonging to the module, followed by the
462# the tests in t/porting
463#
192f56b0 464chdir "t";
ad9b4e6f 465say "Running module tests";
fc134225
MM
466my @test_files = grep { /\.t$/ } find_type_f( $pkg_dir );
467my $exe_dir= $^O =~ /MSWin/ ? "..\\" : './';
468my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`;
ad9b4e6f
A
469unless ($output =~ /All tests successful/) {
470 say $output;
471 exit 1;
472}
473
418f4069 474print "Running tests in t/porting ";
fc134225 475my @tests = glob 'porting/*.t';
418f4069
A
476chomp @tests;
477my @failed;
478foreach my $t (@tests) {
cefd15c2
MM
479 my @not = grep {!/# TODO/ }
480 grep { /^not/ }
481 `${exe_dir}perl -I../lib -I.. $t`;
418f4069
A
482 print @not ? '!' : '.';
483 push @failed => $t if @not;
484}
485print "\n";
486say "Failed tests: @failed" if @failed;
487
488
9807c17b
JL
489say "Attempting to update Maintainers.pl";
490chdir '..';
491
492open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
493open my $new_Maintainers_pl, '>', 'Maintainers.pl';
494
495my $found;
496my $in_mod_section;
497while (<$Maintainers_pl>) {
498 if (!$found) {
499 if ($in_mod_section) {
500 if (/DISTRIBUTION/) {
33c6567b 501 if (s/\Q$old_version/$new_version/) {
9807c17b
JL
502 $found = 1;
503 }
504 }
505
506 if (/^ }/) {
507 $in_mod_section = 0;
508 }
509 }
510
511 if (/\Q$cpan_mod/) {
512 $in_mod_section = 1;
513 }
514 }
515
516 print $new_Maintainers_pl $_;
517}
518
519if ($found) {
520 unlink 'Porting/Maintainers.pl';
521 rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
cd9a1714 522 chmod 0755 => 'Porting/Maintainers.pl';
9807c17b
JL
523}
524else {
525 say "Could not update Porting/Maintainers.pl.";
526 say "Make sure you update this by hand before committing.";
527}
418f4069 528
418f4069 529say "$o_module is now version $new_version";
9807c17b 530say "Now you ought to run a make; make test ...";
418f4069
A
531
532
533__END__