This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Elide use of `rm`
[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.
192f56b0 117In particular, it assumes git, chmod, 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 );
418f4069
A
132
133$| = 1;
134
07a826df 135die "This does not look like a top level directory"
418f4069
A
136 unless -d "cpan" && -d "Porting";
137
418f4069
A
138our @IGNORABLE;
139our %Modules;
140
141use autodie;
142
143require "Porting/Maintainers.pl";
144
418f4069
A
145my %IGNORABLE = map {$_ => 1} @IGNORABLE;
146
147my $package = "02packages.details.txt";
148my $package_url = "http://www.cpan.org/modules/$package";
149my $package_file = "/tmp/$package";
150
b7e2b692
JL
151my @problematic = (
152 'podlators', # weird CUSTOMIZED section due to .PL files
153);
154
418f4069 155
4d18e0a2 156GetOptions ('tarball=s' => \my $tarball,
b5bf278a
A
157 'version=s' => \my $version,
158 force => \my $force,)
4d18e0a2
A
159 or die "Failed to parse arguments";
160
161die "Usage: $0 module [args] [cpan package]" unless @ARGV == 1 || @ARGV == 2;
418f4069 162
5b73aae5
A
163my ($module) = shift;
164my $cpan_mod = @ARGV ? shift : $module;
418f4069 165
4d18e0a2 166
418f4069
A
167my $info = $Modules {$module} or die "Cannot find module $module";
168my $distribution = $$info {DISTRIBUTION};
b5bf278a
A
169
170my @files = glob $$info {FILES};
b7e2b692 171if (!-d $files [0] || grep { $_ eq $module } @problematic) {
b5bf278a
A
172 say "This looks like a setup $0 cannot handle (yet)";
173 unless ($force) {
174 say "Will not continue without a --force option";
175 exit 1;
176 }
177 say "--force is in effect, so we'll soldier on. Wish me luck!";
178}
179
180
181chdir "cpan";
182
83d3dd1d 183my $pkg_dir = $files[0];
418f4069
A
184 $pkg_dir =~ s!.*/!!;
185
186my ($old_version) = $distribution =~ /-([0-9.]+)\.tar\.gz/;
187
188my $o_module = $module;
5b73aae5
A
189if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) {
190 $cpan_mod =~ s/-/::/g;
418f4069
A
191}
192
193#
194# Find the information from CPAN.
195#
4d18e0a2
A
196my $new_file;
197my $new_version;
198unless ($tarball) {
199 #
200 # Poor man's cache
201 #
202 unless (-f $package_file && -M $package_file < 1) {
132246f2
MM
203 eval {
204 require HTTP::Tiny;
205 my $http= HTTP::Tiny->new();
206 $http->mirror( $package_url => $package_file );
207 1
208 } or system wget => $package_url, '-qO', $package_file;
4d18e0a2
A
209 }
210
211 my $new_line = `grep '^$cpan_mod ' $package_file`
212 or die "Cannot find $cpan_mod on CPAN\n";
213 chomp $new_line;
214 (undef, $new_version, my $new_path) = split ' ', $new_line;
3a4316cc
JL
215 if (defined $version) {
216 $new_path =~ s/-$new_version\./-$version\./;
217 $new_version = $version;
218 }
4d18e0a2
A
219 $new_file = (split '/', $new_path) [-1];
220
221 my $url = "http://search.cpan.org/CPAN/authors/id/$new_path";
222 say "Fetching $url";
223 #
224 # Fetch the new distro
225 #
132246f2
MM
226 eval {
227 require HTTP::Tiny;
228 my $http= HTTP::Tiny->new();
229 $http->mirror( $url => $new_file );
230 1
231 } or system wget => $url, '-qO', $new_file;
4d18e0a2
A
232}
233else {
234 $new_file = $tarball;
235 $new_version = $version // ($new_file =~ /-([0-9._]+)\.tar\.gz/) [0];
236}
418f4069
A
237
238my $old_dir = "$pkg_dir-$old_version";
418f4069
A
239
240say "Cleaning out old directory";
241system git => 'clean', '-dfxq', $pkg_dir;
242
418f4069 243say "Unpacking $new_file";
5fb91d48 244Archive::Tar->extract_archive( $new_file );
418f4069 245
618ac2f6 246(my $new_dir = $new_file) =~ s/\.tar\.gz//;
3f7808eb
JL
247# ensure 'make' will update all files
248system('find', $new_dir, '-exec', 'touch', '{}', ';');
418f4069
A
249
250say "Renaming directories";
251rename $pkg_dir => $old_dir;
418f4069 252
83d3dd1d
JL
253say "Creating new package directory";
254mkdir $pkg_dir;
255
256say "Populating new package directory";
257my $map = $$info {MAP};
258my @EXCLUDED_QR;
259my %EXCLUDED_QQ;
260if ($$info {EXCLUDED}) {
261 foreach my $entry (@{$$info {EXCLUDED}}) {
262 if (ref $entry) {push @EXCLUDED_QR => $entry}
263 else {$EXCLUDED_QQ {$entry} = 1}
264 }
265}
266
267FILE: for my $file ( `find $new_dir -type f` ) {
268 chomp $file;
269 my $old_file = $file;
270 $file =~ s{^$new_dir/}{};
271
272 next if $EXCLUDED_QQ{$file};
273 for my $qr (@EXCLUDED_QR) {
274 next FILE if $file =~ $qr;
275 }
276
277 if ( $map ) {
278 for my $key ( sort { length $b <=> length $a } keys %$map ) {
279 my $val = $map->{$key};
280 last if $file =~ s/^$key/$val/;
281 }
282 }
7bbb137d
JL
283 else {
284 $file = $files[0] . '/' . $file;
285 }
83d3dd1d
JL
286
287 if ( $file =~ m{^cpan/} ) {
288 $file =~ s{^cpan/}{};
289 }
290 else {
291 $file = '../' . $file;
292 }
293
294 my $prefix = '';
295 my @parts = split '/', $file;
296 pop @parts;
297 for my $part (@parts) {
298 $prefix .= '/' if $prefix;
299 $prefix .= $part;
300 mkdir $prefix unless -d $prefix;
301 }
302
303 rename $old_file => $file;
304}
192f56b0 305remove_tree( $new_dir );
418f4069
A
306
307if (-f "$old_dir/.gitignore") {
308 say "Restoring .gitignore";
309 system git => 'checkout', "$pkg_dir/.gitignore";
310}
311
ad9b4e6f 312my @new_files = `find $pkg_dir -type f`;
418f4069
A
313chomp @new_files;
314@new_files = grep {$_ ne $pkg_dir} @new_files;
315s!^[^/]+/!! for @new_files;
316my %new_files = map {$_ => 1} @new_files;
317
ad9b4e6f 318my @old_files = `find $old_dir -type f`;
418f4069
A
319chomp @old_files;
320@old_files = grep {$_ ne $old_dir} @old_files;
321s!^[^/]+/!! for @old_files;
322my %old_files = map {$_ => 1} @old_files;
323
418f4069
A
324my @delete;
325my @commit;
326my @gone;
418f4069
A
327FILE:
328foreach my $file (@new_files) {
329 next if -d "$pkg_dir/$file"; # Ignore directories.
330 next if $old_files {$file}; # It's already there.
331 if ($IGNORABLE {$file}) {
332 push @delete => $file;
333 next;
334 }
418f4069
A
335 push @commit => $file;
336}
337foreach my $file (@old_files) {
338 next if -d "$old_dir/$file";
339 next if $new_files {$file};
340 push @gone => $file;
341}
ad9b4e6f
A
342
343#
344# Find all files with an exec bit
345#
346my @exec = `find $pkg_dir -type f -perm +111`;
418f4069 347chomp @exec;
ad9b4e6f
A
348my @de_exec;
349foreach my $file (@exec) {
350 # Remove leading dir
351 $file =~ s!^[^/]+/!!;
352 if ($file =~ m!^t/!) {
353 push @de_exec => $file;
354 next;
355 }
356 # Check to see if the file exists; if it doesn't and doesn't have
357 # the exec bit, remove it.
358 if ($old_files {$file}) {
359 unless (-x "$old_dir/$file") {
360 push @de_exec => $file;
361 }
362 }
363}
418f4069
A
364
365#
366# No need to change the +x bit on files that will be deleted.
367#
ad9b4e6f 368if (@de_exec && @delete) {
a9f5d1d4 369 my %delete = map {+"$pkg_dir/$_" => 1} @delete;
ad9b4e6f 370 @de_exec = grep {!$delete {$_}} @de_exec;
418f4069
A
371}
372
373say "unlink $pkg_dir/$_" for @delete;
374say "git add $pkg_dir/$_" for @commit;
375say "git rm -f $pkg_dir/$_" for @gone;
ad9b4e6f 376say "chmod a-x $pkg_dir/$_" for @de_exec;
418f4069
A
377
378print "Hit return to continue; ^C to abort "; <STDIN>;
379
380unlink "$pkg_dir/$_" for @delete;
381system git => 'add', "$pkg_dir/$_" for @commit;
382system git => 'rm', '-f', "$pkg_dir/$_" for @gone;
ad9b4e6f 383system chmod => 'a-x', "$pkg_dir/$_" for @de_exec;
418f4069 384
9c259538
A
385#
386# Restore anything that is customized.
387# We don't really care whether we've deleted the file - since we
388# do a git restore, it's going to be resurrected if necessary.
389#
390if ($$info {CUSTOMIZED}) {
391 say "Restoring customized files";
392 foreach my $file (@{$$info {CUSTOMIZED}}) {
393 system git => "checkout", "$pkg_dir/$file";
394 }
395}
396
a8121781 397chdir "..";
418f4069
A
398if (@commit) {
399 say "Fixing MANIFEST";
a8121781 400 my $MANIFEST = "MANIFEST";
418f4069
A
401 my $MANIFEST_SORT = "$MANIFEST.sorted";
402 open my $fh, ">>", $MANIFEST;
a8121781 403 say $fh "cpan/$pkg_dir/$_" for @commit;
418f4069 404 close $fh;
a8121781 405 system perl => "Porting/manisort", '--output', $MANIFEST_SORT;
418f4069
A
406 rename $MANIFEST_SORT => $MANIFEST;
407}
408
409
418f4069
A
410print "Running a make ... ";
411system "make > make.log 2>&1" and die "Running make failed, see make.log";
412print "done\n";
413
414#
415# Must clean up, or else t/porting/FindExt.t will fail.
730ad6b9 416# Note that we can always retrieve the original directory with a git checkout.
418f4069
A
417#
418print "About to clean up; hit return or abort (^C) "; <STDIN>;
419
192f56b0
MM
420remove_tree( "cpan/$old_dir" );
421unlink "cpan/$new_file" unless $tarball;
418f4069
A
422
423
ad9b4e6f
A
424#
425# Run the tests. First the test belonging to the module, followed by the
426# the tests in t/porting
427#
192f56b0 428chdir "t";
ad9b4e6f
A
429say "Running module tests";
430my @test_files = `find ../cpan/$pkg_dir -name '*.t' -type f`;
431chomp @test_files;
432my $output = `./perl TEST @test_files`;
433unless ($output =~ /All tests successful/) {
434 say $output;
435 exit 1;
436}
437
418f4069
A
438print "Running tests in t/porting ";
439my @tests = `ls porting/*.t`;
440chomp @tests;
441my @failed;
442foreach my $t (@tests) {
443 my @not = `./perl -I../lib -I.. $t | grep ^not | grep -v "# TODO"`;
444 print @not ? '!' : '.';
445 push @failed => $t if @not;
446}
447print "\n";
448say "Failed tests: @failed" if @failed;
449
450
9807c17b
JL
451say "Attempting to update Maintainers.pl";
452chdir '..';
453
454open my $Maintainers_pl, '<', 'Porting/Maintainers.pl';
455open my $new_Maintainers_pl, '>', 'Maintainers.pl';
456
457my $found;
458my $in_mod_section;
459while (<$Maintainers_pl>) {
460 if (!$found) {
461 if ($in_mod_section) {
462 if (/DISTRIBUTION/) {
33c6567b 463 if (s/\Q$old_version/$new_version/) {
9807c17b
JL
464 $found = 1;
465 }
466 }
467
468 if (/^ }/) {
469 $in_mod_section = 0;
470 }
471 }
472
473 if (/\Q$cpan_mod/) {
474 $in_mod_section = 1;
475 }
476 }
477
478 print $new_Maintainers_pl $_;
479}
480
481if ($found) {
482 unlink 'Porting/Maintainers.pl';
483 rename 'Maintainers.pl' => 'Porting/Maintainers.pl';
484 system chmod => 'a+x', 'Porting/Maintainers.pl';
485}
486else {
487 say "Could not update Porting/Maintainers.pl.";
488 say "Make sure you update this by hand before committing.";
489}
418f4069 490
418f4069 491say "$o_module is now version $new_version";
9807c17b 492say "Now you ought to run a make; make test ...";
418f4069
A
493
494
495__END__