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