X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/83d3dd1de856357daa35501d203988dd67793714..fc134225747f7f6b1e38daa4f85f3c36c99755ee:/Porting/sync-with-cpan

diff --git a/Porting/sync-with-cpan b/Porting/sync-with-cpan
index e3bbc68..0fe3733 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<FILES>
 
 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, chmod, perl, and make
 to be available.
 
 =cut
@@ -127,6 +127,9 @@ use 5.010;
 use strict;
 use warnings;
 use Getopt::Long;
+use Archive::Tar;
+use File::Path qw( remove_tree );
+use File::Find;
 
 $| = 1;
 
@@ -142,9 +145,15 @@ 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
+);
 
 
 GetOptions ('tarball=s'  =>  \my $tarball,
@@ -154,6 +163,16 @@ GetOptions ('tarball=s'  =>  \my $tarball,
 
 die "Usage: $0 module [args] [cpan package]" 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
+};
+
 my ($module)  = shift;
 my  $cpan_mod = @ARGV ? shift : $module;
 
@@ -162,7 +181,7 @@ my  $info         = $Modules {$module} or die "Cannot find module $module";
 my  $distribution = $$info {DISTRIBUTION};
 
 my @files         = glob $$info {FILES};
-if (!-d $files [0]) {
+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";
@@ -194,7 +213,12 @@ 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`
@@ -212,7 +236,12 @@ 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;
@@ -225,11 +254,16 @@ 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;
@@ -248,8 +282,7 @@ if ($$info {EXCLUDED}) {
     }
 }
 
-FILE: for my $file ( `find $new_dir -type f` ) {
-    chomp $file;
+FILE: for my $file ( find_type_f( $new_dir )) {
     my $old_file = $file;
     $file =~ s{^$new_dir/}{};
 
@@ -264,6 +297,9 @@ FILE: for my $file ( `find $new_dir -type f` ) {
             last if $file =~ s/^$key/$val/;
         }
     }
+    else {
+        $file = $files[0] . '/' . $file;
+    }
 
     if ( $file =~ m{^cpan/} ) {
         $file =~ s{^cpan/}{};
@@ -283,21 +319,19 @@ FILE: for my $file ( `find $new_dir -type f` ) {
 
     rename $old_file => $file;
 }
-system 'rm', '-rf', $new_dir;
+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;
@@ -324,8 +358,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
@@ -389,36 +422,35 @@ if (@commit) {
 
 
 print "Running a make ... ";
-system "make > make.log 2>&1" and die "Running make failed, see make.log";
+system "$Config{make} > make.log 2>&1" and die "Running make failed, see make.log";
 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) "; <STDIN>;
 
-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) {
@@ -430,10 +462,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';
+    system chmod => 'a+x', '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__