1#!/usr/bin/env perl 2 3# 4# Script to help out with syncing cpan distros. 5# 6# Does the following: 7# - Fetches the package list from CPAN. Finds the current version of 8# the given package. [1] 9# - Downloads the relevant tarball; unpacks the tarball;. [1] 10# - Clean out the old directory (git clean -dfx) 11# - Moves the old directory out of the way, moves the new directory in place. 12# - Restores any .gitignore file. 13# - Removes files from @IGNORE and EXCLUDED 14# - git add any new files. 15# - git rm any files that are gone. 16# - Remove the +x bit on files in t/ 17# - Remove the +x bit on files that don't have in enabled in the current dir 18# - Restore files mentioned in CUSTOMIZED 19# - Adds new files to MANIFEST 20# - Runs a "make" (assumes a configure has been run) 21# - Cleans up 22# - Runs tests for the package 23# - Runs the porting tests 24# 25# [1] If the --tarball option is given, then CPAN is not consulted. 26# --tarball should be the path to the tarball; the version is extracted 27# from the filename -- but can be overwritten by the --version option. 28# 29# TODO: - Delete files from MANIFEST 30# - Update Porting/Maintainers.pl 31# - Optional, run a full test suite 32# - Handle complicated FILES 33# 34# This is an initial version; no attempt has been made yet to make this 35# portable. It shells out instead of trying to find a Perl solution. 36# In particular, it assumes wget, git, tar, chmod, perl, make, and rm 37# to be available. 38# 39# Usage: perl Porting/sync-with-cpan <module> 40# where <module> is the name it appears in the %Modules hash 41# of Porting/Maintainers.pl 42# 43 44package Maintainers; 45 46use 5.010; 47 48use strict; 49use warnings; 50use Getopt::Long; 51no warnings 'syntax'; 52 53$| = 1; 54 55die "This does not like top level directory" 56 unless -d "cpan" && -d "Porting"; 57 58our @IGNORABLE; 59our %Modules; 60 61use autodie; 62 63require "Porting/Maintainers.pl"; 64 65my %IGNORABLE = map {$_ => 1} @IGNORABLE; 66 67my $package = "02packages.details.txt"; 68my $package_url = "http://www.cpan.org/modules/$package"; 69my $package_file = "/tmp/$package"; 70 71 72GetOptions ('tarball=s' => \my $tarball, 73 'version=s' => \my $version, 74 force => \my $force,) 75 or die "Failed to parse arguments"; 76 77die "Usage: $0 module [args] [cpan package]" unless @ARGV == 1 || @ARGV == 2; 78 79my ($module) = shift; 80my $cpan_mod = @ARGV ? shift : $module; 81 82 83my $info = $Modules {$module} or die "Cannot find module $module"; 84my $distribution = $$info {DISTRIBUTION}; 85 86my @files = glob $$info {FILES}; 87if (@files != 1 || !-d $files [0] || $$info {MAP}) { 88 say "This looks like a setup $0 cannot handle (yet)"; 89 unless ($force) { 90 say "Will not continue without a --force option"; 91 exit 1; 92 } 93 say "--force is in effect, so we'll soldier on. Wish me luck!"; 94} 95 96 97chdir "cpan"; 98 99my $pkg_dir = $$info {FILES}; 100 $pkg_dir =~ s!.*/!!; 101 102my ($old_version) = $distribution =~ /-([0-9.]+)\.tar\.gz/; 103 104my $o_module = $module; 105if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) { 106 $cpan_mod =~ s/-/::/g; 107} 108 109# 110# Find the information from CPAN. 111# 112my $new_file; 113my $new_version; 114unless ($tarball) { 115 # 116 # Poor man's cache 117 # 118 unless (-f $package_file && -M $package_file < 1) { 119 system wget => $package_url, '-qO', $package_file; 120 } 121 122 my $new_line = `grep '^$cpan_mod ' $package_file` 123 or die "Cannot find $cpan_mod on CPAN\n"; 124 chomp $new_line; 125 (undef, $new_version, my $new_path) = split ' ', $new_line; 126 $new_file = (split '/', $new_path) [-1]; 127 128 my $url = "http://search.cpan.org/CPAN/authors/id/$new_path"; 129 say "Fetching $url"; 130 # 131 # Fetch the new distro 132 # 133 system wget => $url, '-qO', $new_file; 134} 135else { 136 $new_file = $tarball; 137 $new_version = $version // ($new_file =~ /-([0-9._]+)\.tar\.gz/) [0]; 138} 139 140my $old_dir = "$pkg_dir-$old_version"; 141my $new_dir = "$pkg_dir-$new_version"; 142 143say "Cleaning out old directory"; 144system git => 'clean', '-dfxq', $pkg_dir; 145 146say "Unpacking $new_file"; 147 148system tar => 'xfz', $new_file; 149 150say "Renaming directories"; 151rename $pkg_dir => $old_dir; 152rename $new_dir => $pkg_dir; 153 154 155if (-f "$old_dir/.gitignore") { 156 say "Restoring .gitignore"; 157 system git => 'checkout', "$pkg_dir/.gitignore"; 158} 159 160my @new_files = `find $pkg_dir -type f`; 161chomp @new_files; 162@new_files = grep {$_ ne $pkg_dir} @new_files; 163s!^[^/]+/!! for @new_files; 164my %new_files = map {$_ => 1} @new_files; 165 166my @old_files = `find $old_dir -type f`; 167chomp @old_files; 168@old_files = grep {$_ ne $old_dir} @old_files; 169s!^[^/]+/!! for @old_files; 170my %old_files = map {$_ => 1} @old_files; 171 172# 173# Find files that can be deleted. 174# 175my @EXCLUDED_QR; 176my %EXCLUDED_QQ; 177if ($$info {EXCLUDED}) { 178 foreach my $entry (@{$$info {EXCLUDED}}) { 179 if (ref $entry) {push @EXCLUDED_QR => $entry} 180 else {$EXCLUDED_QQ {$entry} = 1} 181 } 182} 183 184my @delete; 185my @commit; 186my @gone; 187FILE: 188foreach my $file (@new_files) { 189 next if -d "$pkg_dir/$file"; # Ignore directories. 190 next if $old_files {$file}; # It's already there. 191 if ($IGNORABLE {$file}) { 192 push @delete => $file; 193 next; 194 } 195 if ($EXCLUDED_QQ {$file}) { 196 push @delete => $file; 197 next; 198 } 199 foreach my $pattern (@EXCLUDED_QR) { 200 if ($file =~ /$pattern/) { 201 push @delete => $file; 202 next FILE; 203 } 204 } 205 push @commit => $file; 206} 207foreach my $file (@old_files) { 208 next if -d "$old_dir/$file"; 209 next if $new_files {$file}; 210 push @gone => $file; 211} 212 213# 214# Find all files with an exec bit 215# 216my @exec = `find $pkg_dir -type f -perm +111`; 217chomp @exec; 218my @de_exec; 219foreach my $file (@exec) { 220 # Remove leading dir 221 $file =~ s!^[^/]+/!!; 222 if ($file =~ m!^t/!) { 223 push @de_exec => $file; 224 next; 225 } 226 # Check to see if the file exists; if it doesn't and doesn't have 227 # the exec bit, remove it. 228 if ($old_files {$file}) { 229 unless (-x "$old_dir/$file") { 230 push @de_exec => $file; 231 } 232 } 233} 234 235# 236# No need to change the +x bit on files that will be deleted. 237# 238if (@de_exec && @delete) { 239 my %delete = map {+"$pkg_dir/$_" => 1} @delete; 240 @de_exec = grep {!$delete {$_}} @de_exec; 241} 242 243say "unlink $pkg_dir/$_" for @delete; 244say "git add $pkg_dir/$_" for @commit; 245say "git rm -f $pkg_dir/$_" for @gone; 246say "chmod a-x $pkg_dir/$_" for @de_exec; 247 248print "Hit return to continue; ^C to abort "; <STDIN>; 249 250unlink "$pkg_dir/$_" for @delete; 251system git => 'add', "$pkg_dir/$_" for @commit; 252system git => 'rm', '-f', "$pkg_dir/$_" for @gone; 253system chmod => 'a-x', "$pkg_dir/$_" for @de_exec; 254 255# 256# Restore anything that is customized. 257# We don't really care whether we've deleted the file - since we 258# do a git restore, it's going to be resurrected if necessary. 259# 260if ($$info {CUSTOMIZED}) { 261 say "Restoring customized files"; 262 foreach my $file (@{$$info {CUSTOMIZED}}) { 263 system git => "checkout", "$pkg_dir/$file"; 264 } 265} 266 267chdir ".."; 268if (@commit) { 269 say "Fixing MANIFEST"; 270 my $MANIFEST = "MANIFEST"; 271 my $MANIFEST_SORT = "$MANIFEST.sorted"; 272 open my $fh, ">>", $MANIFEST; 273 say $fh "cpan/$pkg_dir/$_" for @commit; 274 close $fh; 275 system perl => "Porting/manisort", '--output', $MANIFEST_SORT; 276 rename $MANIFEST_SORT => $MANIFEST; 277} 278 279 280print "Running a make ... "; 281system "make > make.log 2>&1" and die "Running make failed, see make.log"; 282print "done\n"; 283 284# 285# Must clean up, or else t/porting/FindExt.t will fail. 286# Note that we can always retrieve the orginal directory with a git checkout. 287# 288print "About to clean up; hit return or abort (^C) "; <STDIN>; 289 290chdir "cpan"; 291system rm => '-r', $old_dir; 292unlink $new_file unless $tarball; 293 294 295# 296# Run the tests. First the test belonging to the module, followed by the 297# the tests in t/porting 298# 299chdir "../t"; 300say "Running module tests"; 301my @test_files = `find ../cpan/$pkg_dir -name '*.t' -type f`; 302chomp @test_files; 303my $output = `./perl TEST @test_files`; 304unless ($output =~ /All tests successful/) { 305 say $output; 306 exit 1; 307} 308 309print "Running tests in t/porting "; 310my @tests = `ls porting/*.t`; 311chomp @tests; 312my @failed; 313foreach my $t (@tests) { 314 my @not = `./perl -I../lib -I.. $t | grep ^not | grep -v "# TODO"`; 315 print @not ? '!' : '.'; 316 push @failed => $t if @not; 317} 318print "\n"; 319say "Failed tests: @failed" if @failed; 320 321 322print "Now you ought to run a make; make test ...\n"; 323 324say "Do not forget to update Porting/Maintainers.pl before committing"; 325say "$o_module is now version $new_version"; 326 327 328__END__ 329