X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/3f7808ebe053a9274d087cc79a5e84105fb8428d..3d6de2cd13dfe0ce6162563bc69ff8f6329e8664:/Porting/sync-with-cpan diff --git a/Porting/sync-with-cpan b/Porting/sync-with-cpan index f6f3aeb..d0cc1d6 100755 --- a/Porting/sync-with-cpan +++ b/Porting/sync-with-cpan @@ -2,7 +2,7 @@ =head1 NAME -Porting/sync-with-cpan +Porting/sync-with-cpan - Synchronize with CPAN distributions =head1 SYNOPSIS @@ -114,7 +114,7 @@ Handle complicated C This is an initial version; no attempt has been made yet to make this portable. It shells out instead of trying to find a Perl solution. -In particular, it assumes wget, git, tar, chmod, perl, make, and rm +In particular, it assumes git, perl, and make to be available. =cut @@ -127,6 +127,10 @@ use 5.010; use strict; use warnings; use Getopt::Long; +use Archive::Tar; +use File::Path qw( remove_tree ); +use File::Find; +use Config qw( %Config ); $| = 1; @@ -142,17 +146,62 @@ require "Porting/Maintainers.pl"; my %IGNORABLE = map {$_ => 1} @IGNORABLE; +my $tmpdir= $ENV{ TEMP } // '/tmp'; + my $package = "02packages.details.txt"; my $package_url = "http://www.cpan.org/modules/$package"; -my $package_file = "/tmp/$package"; +my $package_file = "$tmpdir/$package"; # this is a cache + +my @problematic = ( + 'podlators', # weird CUSTOMIZED section due to .PL files +); +sub usage +{ + my $err = shift and select STDERR; + print "Usage: $0 module [args] [cpan package]\n"; + exit $err; +} + GetOptions ('tarball=s' => \my $tarball, 'version=s' => \my $version, - force => \my $force,) - or die "Failed to parse arguments"; + force => \my $force, + help => sub { usage 0; }, + ) or die "Failed to parse arguments"; + +usage 1 unless @ARGV == 1 || @ARGV == 2; + +sub find_type_f { + my @res; + find( { no_chdir => 1, wanted => sub { + my $file= $File::Find::name; + return unless -f $file; + push @res, $file + }}, @_ ); + @res +}; + +# Equivalent of `chmod a-x` +sub de_exec { + for my $filename ( @_ ) { + my $mode= (stat $filename)[2] & 0777; + if( $mode & 0111 ) { # exec-bit set + chmod $mode & 0666, $filename; + }; + } +} -die "Usage: $0 module [args] [cpan package]" unless @ARGV == 1 || @ARGV == 2; +sub make { + my @args= @_; + if( $^O eq 'MSWin32') { + chdir "Win32"; + system "$Config{make} @args> ..\\make.log 2>&1" and die "Running make failed, see make.log"; + chdir '..'; + } else { + system "$Config{make} @args> make.log 2>&1" and die "Running make failed, see make.log"; + }; +}; my ($module) = shift; my $cpan_mod = @ARGV ? shift : $module; @@ -162,7 +211,7 @@ my $info = $Modules {$module} or die "Cannot find module $module"; my $distribution = $$info {DISTRIBUTION}; my @files = glob $$info {FILES}; -if (@files != 1 || !-d $files [0] || $$info {MAP}) { +if (!-d $files [0] || grep { $_ eq $module } @problematic) { say "This looks like a setup $0 cannot handle (yet)"; unless ($force) { say "Will not continue without a --force option"; @@ -174,10 +223,10 @@ if (@files != 1 || !-d $files [0] || $$info {MAP}) { chdir "cpan"; -my $pkg_dir = $$info {FILES}; +my $pkg_dir = $files[0]; $pkg_dir =~ s!.*/!!; -my ($old_version) = $distribution =~ /-([0-9.]+)\.tar\.gz/; +my ($old_version) = $distribution =~ /-([0-9.]+(?:-TRIAL[0-9]*)?)\.tar\.gz/; my $o_module = $module; if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) { @@ -194,12 +243,17 @@ unless ($tarball) { # Poor man's cache # unless (-f $package_file && -M $package_file < 1) { - system wget => $package_url, '-qO', $package_file; + eval { + require HTTP::Tiny; + my $http= HTTP::Tiny->new(); + $http->mirror( $package_url => $package_file ); + 1 + } or system wget => $package_url, '-qO', $package_file; } - my $new_line = `grep '^$cpan_mod ' $package_file` + open my $fh, '<', $package_file; + (my $new_line) = grep {/^$cpan_mod/} <$fh> # Yes, this needs a lot of memory or die "Cannot find $cpan_mod on CPAN\n"; - chomp $new_line; (undef, $new_version, my $new_path) = split ' ', $new_line; if (defined $version) { $new_path =~ s/-$new_version\./-$version\./; @@ -212,11 +266,16 @@ unless ($tarball) { # # Fetch the new distro # - system wget => $url, '-qO', $new_file; + eval { + require HTTP::Tiny; + my $http= HTTP::Tiny->new(); + $http->mirror( $url => $new_file ); + 1 + } or system wget => $url, '-qO', $new_file; } else { $new_file = $tarball; - $new_version = $version // ($new_file =~ /-([0-9._]+)\.tar\.gz/) [0]; + $new_version = $version // ($new_file =~ /-([0-9._]+(?:-TRIAL[0-9]*)?)\.tar\.gz/) [0]; } my $old_dir = "$pkg_dir-$old_version"; @@ -225,46 +284,88 @@ say "Cleaning out old directory"; system git => 'clean', '-dfxq', $pkg_dir; say "Unpacking $new_file"; +Archive::Tar->extract_archive( $new_file ); -system tar => 'xfz', $new_file; (my $new_dir = $new_file) =~ s/\.tar\.gz//; # ensure 'make' will update all files -system('find', $new_dir, '-exec', 'touch', '{}', ';'); +my $t= time; +for my $file (find_type_f($new_dir)) { + open(my $fh,">>$file") || die "Cannot write $file:$!"; + close($fh); + utime($t,$t,$file); +}; say "Renaming directories"; rename $pkg_dir => $old_dir; -rename $new_dir => $pkg_dir; +say "Creating new package directory"; +mkdir $pkg_dir; + +say "Populating new package directory"; +my $map = $$info {MAP}; +my @EXCLUDED_QR; +my %EXCLUDED_QQ; +if ($$info {EXCLUDED}) { + foreach my $entry (@{$$info {EXCLUDED}}) { + if (ref $entry) {push @EXCLUDED_QR => $entry} + else {$EXCLUDED_QQ {$entry} = 1} + } +} + +FILE: for my $file ( find_type_f( $new_dir )) { + my $old_file = $file; + $file =~ s{^$new_dir/}{}; + + next if $EXCLUDED_QQ{$file}; + for my $qr (@EXCLUDED_QR) { + next FILE if $file =~ $qr; + } + + if ( $map ) { + for my $key ( sort { length $b <=> length $a } keys %$map ) { + my $val = $map->{$key}; + last if $file =~ s/^$key/$val/; + } + } + else { + $file = $files[0] . '/' . $file; + } + + if ( $file =~ m{^cpan/} ) { + $file =~ s{^cpan/}{}; + } + else { + $file = '../' . $file; + } + + my $prefix = ''; + my @parts = split '/', $file; + pop @parts; + for my $part (@parts) { + $prefix .= '/' if $prefix; + $prefix .= $part; + mkdir $prefix unless -d $prefix; + } + + rename $old_file => $file; +} +remove_tree( $new_dir ); if (-f "$old_dir/.gitignore") { say "Restoring .gitignore"; system git => 'checkout', "$pkg_dir/.gitignore"; } -my @new_files = `find $pkg_dir -type f`; -chomp @new_files; +my @new_files = find_type_f( $pkg_dir ); @new_files = grep {$_ ne $pkg_dir} @new_files; s!^[^/]+/!! for @new_files; my %new_files = map {$_ => 1} @new_files; -my @old_files = `find $old_dir -type f`; -chomp @old_files; +my @old_files = find_type_f( $old_dir ); @old_files = grep {$_ ne $old_dir} @old_files; s!^[^/]+/!! for @old_files; my %old_files = map {$_ => 1} @old_files; -# -# Find files that can be deleted. -# -my @EXCLUDED_QR; -my %EXCLUDED_QQ; -if ($$info {EXCLUDED}) { - foreach my $entry (@{$$info {EXCLUDED}}) { - if (ref $entry) {push @EXCLUDED_QR => $entry} - else {$EXCLUDED_QQ {$entry} = 1} - } -} - my @delete; my @commit; my @gone; @@ -276,16 +377,6 @@ foreach my $file (@new_files) { push @delete => $file; next; } - if ($EXCLUDED_QQ {$file}) { - push @delete => $file; - next; - } - foreach my $pattern (@EXCLUDED_QR) { - if ($file =~ /$pattern/) { - push @delete => $file; - next FILE; - } - } push @commit => $file; } foreach my $file (@old_files) { @@ -297,8 +388,7 @@ foreach my $file (@old_files) { # # Find all files with an exec bit # -my @exec = `find $pkg_dir -type f -perm +111`; -chomp @exec; +my @exec = find_type_f( $pkg_dir ); my @de_exec; foreach my $file (@exec) { # Remove leading dir @@ -334,7 +424,7 @@ print "Hit return to continue; ^C to abort "; ; unlink "$pkg_dir/$_" for @delete; system git => 'add', "$pkg_dir/$_" for @commit; system git => 'rm', '-f', "$pkg_dir/$_" for @gone; -system chmod => 'a-x', "$pkg_dir/$_" for @de_exec; +de_exec( "$pkg_dir/$_" ) for @de_exec; # # Restore anything that is customized. @@ -362,40 +452,41 @@ if (@commit) { print "Running a make ... "; -system "make > make.log 2>&1" and die "Running make failed, see make.log"; +# Prepare for running (selected) tests +make 'test-prep'; print "done\n"; # # Must clean up, or else t/porting/FindExt.t will fail. -# Note that we can always retrieve the orginal directory with a git checkout. +# Note that we can always retrieve the original directory with a git checkout. # print "About to clean up; hit return or abort (^C) "; ; -chdir "cpan"; -system rm => '-r', $old_dir; -unlink $new_file unless $tarball; - +remove_tree( "cpan/$old_dir" ); +unlink "cpan/$new_file" unless $tarball; # # Run the tests. First the test belonging to the module, followed by the # the tests in t/porting # -chdir "../t"; +chdir "t"; say "Running module tests"; -my @test_files = `find ../cpan/$pkg_dir -name '*.t' -type f`; -chomp @test_files; -my $output = `./perl TEST @test_files`; +my @test_files = grep { /\.t$/ } find_type_f( $pkg_dir ); +my $exe_dir= $^O =~ /MSWin/ ? "..\\" : './'; +my $output = `${exe_dir}perl$Config{_exe} TEST @test_files`; unless ($output =~ /All tests successful/) { say $output; exit 1; } print "Running tests in t/porting "; -my @tests = `ls porting/*.t`; +my @tests = glob 'porting/*.t'; chomp @tests; my @failed; foreach my $t (@tests) { - my @not = `./perl -I../lib -I.. $t | grep ^not | grep -v "# TODO"`; + my @not = grep {!/# TODO/ } + grep { /^not/ } + `${exe_dir}perl -I../lib -I.. $t`; print @not ? '!' : '.'; push @failed => $t if @not; } @@ -403,10 +494,48 @@ print "\n"; say "Failed tests: @failed" if @failed; -print "Now you ought to run a make; make test ...\n"; +say "Attempting to update Maintainers.pl"; +chdir '..'; + +open my $Maintainers_pl, '<', 'Porting/Maintainers.pl'; +open my $new_Maintainers_pl, '>', 'Maintainers.pl'; + +my $found; +my $in_mod_section; +while (<$Maintainers_pl>) { + if (!$found) { + if ($in_mod_section) { + if (/DISTRIBUTION/) { + if (s/\Q$old_version/$new_version/) { + $found = 1; + } + } + + if (/^ }/) { + $in_mod_section = 0; + } + } + + if (/\Q$cpan_mod/) { + $in_mod_section = 1; + } + } + + print $new_Maintainers_pl $_; +} + +if ($found) { + unlink 'Porting/Maintainers.pl'; + rename 'Maintainers.pl' => 'Porting/Maintainers.pl'; + chmod 0755 => 'Porting/Maintainers.pl'; +} +else { + say "Could not update Porting/Maintainers.pl."; + say "Make sure you update this by hand before committing."; +} -say "Do not forget to update Porting/Maintainers.pl before committing"; say "$o_module is now version $new_version"; +say "Now you ought to run a make; make test ..."; __END__