=head1 NAME
-Porting/sync-with-cpan
+Porting/sync-with-cpan - Synchronize with CPAN distributions
=head1 SYNOPSIS
- perl Porting/sync-with-cpan <module>
+ sh ./Configure
+ perl Porting/sync-with-cpan <module>
where <module> is the name it appears in the C<%Modules> hash
of F<Porting/Maintainers.pl>
=item *
-Adds new files to F<MANIFEST>
+Updates the contents of F<MANIFEST>
=item *
C<--tarball> should be the path to the tarball; the version is extracted
from the filename -- but can be overwritten by the C<--version> option.
-=head1 TODO
+=head1 OPTIONS
=over 4
-=item *
+=item C<--jobs> I<N>
+
+When running C<make>, pass a C<< -jI<N> >> option to it.
+
+=back
+
+=head1 TODO
-Delete files from F<MANIFEST>
+=over 4
=item *
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
use strict;
use warnings;
use Getopt::Long;
-no warnings 'syntax';
+use Archive::Tar;
+use File::Basename qw( basename );
+use File::Path qw( remove_tree );
+use File::Find;
+use File::Spec::Functions qw( tmpdir rel2abs );
+use Config qw( %Config );
$| = 1;
-die "This does not like top level directory"
+use constant WIN32 => $^O eq 'MSWin32';
+
+die "This does not look like a top level directory"
unless -d "cpan" && -d "Porting";
+# Check that there's a Makefile, if needed; otherwise, we'll do most of our
+# work only to fail when we try to run make, and the user will have to
+# either unpick everything we've done, or do the rest manually.
+die "Please run Configure before using $0\n"
+ if !WIN32 && !-f "Makefile";
+
our @IGNORABLE;
our %Modules;
use autodie;
-require "Porting/Maintainers.pl";
+require "./Porting/Maintainers.pl";
+
+my $MAKE_LOG = 'make.log';
my %IGNORABLE = map {$_ => 1} @IGNORABLE;
+my $tmpdir = tmpdir();
+
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";
+ 'jobs=i' => \my $make_jobs,
+ 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 {
+ 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;
+# Equivalent of `chmod +w`
+sub make_writable {
+ my ($filename) = @_;
+ my $mode = (stat $filename)[2] & 0777;
+ if (!($mode & 0222)) { # not writable
+ chmod $mode | (0222 & ~umask), $filename;
+ }
+}
+
+sub make {
+ my @args= @_;
+ unshift @args, "-j$make_jobs" if defined $make_jobs;
+ if (WIN32) {
+ 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;
+my $info = $Modules{$module};
+if (!$info) {
+ # Maybe the user said "Test-Simple" instead of "Test::Simple", or
+ # "IO::Compress" instead of "IO-Compress". See if we can fix it up.
+ my $guess = $module;
+ s/-/::/g or s/::/-/g for $guess;
+ $info = $Modules{$guess} or die <<"EOF";
+Cannot find module $module.
+The available options are listed in the %Modules hash in Porting/Maintainers.pl
+EOF
+ say "Guessing you meant $guess instead of $module";
+ $module = $guess;
+}
+
+if ($info->{CUSTOMIZED}) {
+ print <<"EOF";
+$module has a CUSTOMIZED entry in Porting/Maintainers.pl.
+
+This program's behaviour is to copy every CUSTOMIZED file into the version
+of the module being imported. But that might not be the right thing: in some
+cases, the new CPAN version will supersede whatever changes had previously
+been made in blead, so it would be better to import the new CPAN files.
+
+If you've checked that the CUSTOMIZED versions are still correct, you can
+proceed now. Otherwise, you should abort and investigate the situation. If
+the blead customizations are no longer needed, delete the CUSTOMIZED entry
+for $module in Porting/Maintainers.pl (and you'll also need to regenerate
+t/porting/customized.dat in that case; see t/porting/customized.t).
+
+EOF
+ print "Hit return to continue; ^C to abort "; <STDIN>;
+}
+
+my $cpan_mod = @ARGV ? shift : $module;
-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";
say "--force is in effect, so we'll soldier on. Wish me luck!";
}
+use Cwd 'cwd';
+my $orig_pwd = cwd();
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 !~ /::/) {
$cpan_mod =~ s/-/::/g;
}
+sub wget {
+ my ($url, $saveas) = @_;
+ my $ht_res;
+ eval {
+ require IO::Socket::SSL;
+ require Net::SSLeay;
+ require HTTP::Tiny;
+ my $http = HTTP::Tiny->new();
+ $ht_res = $http->mirror( $url => $saveas );
+ 1;
+ } or
+ # Try harder to download the file
+ # Some system do not have wget. Fall back to curl if we do not
+ # have it. On Windows, `which wget` is not going to work, so
+ # just use wget, as this script has always done.
+ WIN32 || -x substr(`which wget`, 0, -1)
+ ? system wget => $url, '-qO', $saveas
+ : system curl => $url, '-sSo', $saveas;
+
+ # We were able to use HTTP::Tiny and it didn't have fatal errors,
+ # but we failed the request
+ if ( $ht_res && ! $ht_res->{'success'} ) {
+ die "Cannot retrieve file: $url\n" .
+ sprintf "Status: %s\nReason: %s\nContent: %s\n",
+ map $_ // '(unavailable)', @{$ht_res}{qw< status reason content >};
+ }
+}
+
#
# Find the information from CPAN.
#
my $new_file;
my $new_version;
-unless ($tarball) {
+if (defined $tarball) {
+ $tarball = rel2abs( $tarball, $orig_pwd ) ;
+ die "Tarball $tarball does not exist\n" if !-e $tarball;
+ die "Tarball $tarball is not a plain file\n" if !-f _;
+ $new_file = $tarball;
+ $new_version = $version // ($new_file =~ /-([0-9._]+(?:-TRIAL[0-9]*)?)\.tar\.gz/) [0];
+ die "Blead and that tarball both have version $new_version of $module\n"
+ if $new_version eq $old_version;
+}
+else {
#
# Poor man's cache
#
unless (-f $package_file && -M $package_file < 1) {
- system wget => $package_url, '-qO', $package_file;
+ wget $package_url, $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\./;
+ $new_version = $version;
+ }
$new_file = (split '/', $new_path) [-1];
- my $url = "http://search.cpan.org/CPAN/authors/id/$new_path";
+ die "The latest version of $module is $new_version, but blead already has it\n"
+ if $new_version eq $old_version;
+
+ my $url = "https://cpan.metacpan.org/authors/id/$new_path";
say "Fetching $url";
#
# Fetch the new distro
#
- system wget => $url, '-qO', $new_file;
-}
-else {
- $new_file = $tarball;
- $new_version = $version // ($new_file =~ /-([0-9._]+)\.tar\.gz/) [0];
+ wget $url, $new_file;
}
my $old_dir = "$pkg_dir-$old_version";
-my $new_dir = "$pkg_dir-$new_version";
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 = basename($new_file)) =~ s/\.tar\.gz//;
+# ensure 'make' will update all files
+my $t= time;
+for my $file (find_type_f($new_dir)) {
+ make_writable($file); # for convenience if the user later edits it
+ 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;
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) {
#
# 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
@de_exec = grep {!$delete {$_}} @de_exec;
}
+#
+# Mustn't change the +x bit on files that are whitelisted
+#
+if (@de_exec) {
+ my %permitted = map { (my $x = $_) =~ tr/\n//d; $x => 1 } grep !/^#/,
+ do { local @ARGV = '../Porting/exec-bit.txt'; <> };
+ @de_exec = grep !$permitted{"cpan/$pkg_dir/$_"}, @de_exec;
+}
+
say "unlink $pkg_dir/$_" for @delete;
say "git add $pkg_dir/$_" for @commit;
say "git rm -f $pkg_dir/$_" for @gone;
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.
}
chdir "..";
-if (@commit) {
+if (@commit || @gone) {
say "Fixing MANIFEST";
- my $MANIFEST = "MANIFEST";
- my $MANIFEST_SORT = "$MANIFEST.sorted";
- open my $fh, ">>", $MANIFEST;
- say $fh "cpan/$pkg_dir/$_" for @commit;
- close $fh;
- system perl => "Porting/manisort", '--output', $MANIFEST_SORT;
- rename $MANIFEST_SORT => $MANIFEST;
+ my $MANIFEST = "MANIFEST";
+ my $MANIFEST_NEW = "$MANIFEST.new";
+
+ open my $orig, "<", $MANIFEST
+ or die "Failed to open $MANIFEST for reading: $!\n";
+ open my $new, ">", $MANIFEST_NEW
+ or die "Failed to open $MANIFEST_NEW for writing: $!\n";
+ my %gone = map +("cpan/$pkg_dir/$_" => 1), @gone;
+ while (my $line = <$orig>) {
+ my ($file) = $line =~ /^(\S+)/
+ or die "Can't parse MANIFEST line: $line";
+ print $new $line if !$gone{$file};
+ }
+
+ say $new "cpan/$pkg_dir/$_" for @commit;
+
+ close $new or die "Can't close $MANIFEST: $!\n";
+
+ system $^X => "Porting/manisort", '--quiet', "--output=$MANIFEST", $MANIFEST_NEW;
+ unlink $MANIFEST_NEW
+ or die "Can't delete temporary $MANIFEST_NEW: $!\n";
}
-print "Running a make ... ";
-system "make > make.log 2>&1" and die "Running make failed, see make.log";
+print "Running a make and saving its output to $MAKE_LOG ... ";
+# Prepare for running (selected) tests
+make 'test-prep';
print "done\n";
+# The build system installs code from CPAN dists into the lib/ directory,
+# creating directories as needed. This means that the cleaning-related rules
+# in the Makefile need to know which directories to clean up. The Makefile
+# is generated by Configure from Makefile.SH, so *that* file needs the list
+# of directories. regen/lib_cleanup.pl is capable of automatically updating
+# the contents of Makefile.SH (and win32/Makefile, which needs similar but
+# not identical lists of directories), so we can just run that (using the
+# newly-built Perl, as is done with the regen programs run by "make regen").
+#
+# We do this if any files at all have been added or deleted, regardless of
+# whether those changes result in any directories being added or deleted,
+# because the alternative would be to replicate the regen/lib_cleanup.pl
+# logic here. That's fine, because regen/lib_cleanup.pl is idempotent if run
+# repeatedly.
+if (@commit || @gone) {
+ say "Running regen/lib_cleanup.pl to handle potential added/deleted dirs";
+ my $exe_dir = WIN32 ? ".\\" : './';
+ system "${exe_dir}perl$Config{_exe}", "-Ilib", "regen/lib_cleanup.pl"
+ and die "regen/lib_cleanup.pl failed\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
+# 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( "../cpan/$pkg_dir" );
+my $exe_dir = WIN32 ? "..\\" : './';
+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;
}
say "Failed tests: @failed" if @failed;
-print "Now you ought to run a make; make test ...\n";
+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$module/) {
+ $in_mod_section = 1;
+ }
+ }
+
+ print $new_Maintainers_pl $_;
+}
+
+if ($found) {
+ say "Successfully updated Maintainers.pl";
+ 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.";
+}
+
+print <<"EOF";
+
+=======================================================================
+
+$o_module is now at version $new_version
+Next, you should run a "make test".
+
+Hopefully that will complete successfully, but if not, you can make any
+changes you need to get the tests to pass. Don't forget that you'll need
+a "CUSTOMIZED" entry in Porting/Maintainers.pl if you change any of the
+files under cpan/$pkg_dir.
-say "Do not forget to update Porting/Maintainers.pl before committing";
-say "$o_module is now version $new_version";
+Once all tests pass, you can "git add -u" and "git commit" the changes.
+EOF
__END__
https://perl5.git.perl.org / perl5.git / blobdiff