Commit | Line | Data |
---|---|---|
33e80a47 | 1 | #!/usr/bin/env perl |
418f4069 | 2 | |
c5e3e317 JL |
3 | =head1 NAME |
4 | ||
f703fc96 | 5 | Porting/sync-with-cpan - Synchronize with CPAN distributions |
c5e3e317 JL |
6 | |
7 | =head1 SYNOPSIS | |
8 | ||
9 | perl Porting/sync-with-cpan <module> | |
10 | ||
11 | where <module> is the name it appears in the C<%Modules> hash | |
12 | of F<Porting/Maintainers.pl> | |
13 | ||
14 | =head1 DESCRIPTION | |
15 | ||
16 | Script to help out with syncing cpan distros. | |
17 | ||
18 | Does the following: | |
19 | ||
20 | =over 4 | |
21 | ||
22 | =item * | |
23 | ||
24 | Fetches the package list from CPAN. Finds the current version of the given | |
25 | package. [1] | |
26 | ||
27 | =item * | |
28 | ||
29 | Downloads the relevant tarball; unpacks the tarball. [1] | |
30 | ||
31 | =item * | |
32 | ||
33 | Clean out the old directory (C<git clean -dfx>) | |
34 | ||
35 | =item * | |
36 | ||
37 | Moves the old directory out of the way, moves the new directory in place. | |
38 | ||
39 | =item * | |
40 | ||
41 | Restores any F<.gitignore> file. | |
42 | ||
43 | =item * | |
44 | ||
45 | Removes files from C<@IGNORE> and C<EXCLUDED> | |
46 | ||
47 | =item * | |
48 | ||
49 | C<git add> any new files. | |
50 | ||
51 | =item * | |
52 | ||
53 | C<git rm> any files that are gone. | |
54 | ||
55 | =item * | |
56 | ||
57 | Remove the +x bit on files in F<t/> | |
58 | ||
59 | =item * | |
60 | ||
61 | Remove the +x bit on files that don't have it enabled in the current dir | |
62 | ||
63 | =item * | |
64 | ||
65 | Restore files mentioned in C<CUSTOMIZED> | |
66 | ||
67 | =item * | |
68 | ||
69 | Adds new files to F<MANIFEST> | |
70 | ||
71 | =item * | |
72 | ||
73 | Runs a C<make> (assumes a configure has been run) | |
74 | ||
75 | =item * | |
76 | ||
77 | Cleans up | |
78 | ||
79 | =item * | |
80 | ||
81 | Runs tests for the package | |
82 | ||
83 | =item * | |
84 | ||
85 | Runs the porting tests | |
86 | ||
87 | =back | |
88 | ||
89 | [1] If the C<--tarball> option is given, then CPAN is not consulted. | |
90 | C<--tarball> should be the path to the tarball; the version is extracted | |
91 | from the filename -- but can be overwritten by the C<--version> option. | |
92 | ||
93 | =head1 TODO | |
94 | ||
95 | =over 4 | |
96 | ||
97 | =item * | |
98 | ||
99 | Delete files from F<MANIFEST> | |
100 | ||
101 | =item * | |
102 | ||
103 | Update F<Porting/Maintainers.pl> | |
104 | ||
105 | =item * | |
106 | ||
107 | Optional, run a full test suite | |
108 | ||
109 | =item * | |
110 | ||
111 | Handle complicated C<FILES> | |
112 | ||
113 | =back | |
114 | ||
115 | This is an initial version; no attempt has been made yet to make this | |
116 | portable. It shells out instead of trying to find a Perl solution. | |
192f56b0 | 117 | In particular, it assumes git, chmod, perl, and make |
c5e3e317 JL |
118 | to be available. |
119 | ||
120 | =cut | |
121 | ||
418f4069 | 122 | |
4d18e0a2 A |
123 | package Maintainers; |
124 | ||
418f4069 A |
125 | use 5.010; |
126 | ||
127 | use strict; | |
128 | use warnings; | |
4d18e0a2 | 129 | use Getopt::Long; |
a1450e8b | 130 | use Archive::Tar; |
192f56b0 | 131 | use File::Path qw( remove_tree ); |
418f4069 A |
132 | |
133 | $| = 1; | |
134 | ||
07a826df | 135 | die "This does not look like a top level directory" |
418f4069 A |
136 | unless -d "cpan" && -d "Porting"; |
137 | ||
418f4069 A |
138 | our @IGNORABLE; |
139 | our %Modules; | |
140 | ||
141 | use autodie; | |
142 | ||
143 | require "Porting/Maintainers.pl"; | |
144 | ||
418f4069 A |
145 | my %IGNORABLE = map {$_ => 1} @IGNORABLE; |
146 | ||
147 | my $package = "02packages.details.txt"; | |
148 | my $package_url = "http://www.cpan.org/modules/$package"; | |
149 | my $package_file = "/tmp/$package"; | |
150 | ||
b7e2b692 JL |
151 | my @problematic = ( |
152 | 'podlators', # weird CUSTOMIZED section due to .PL files | |
153 | ); | |
154 | ||
418f4069 | 155 | |
4d18e0a2 | 156 | GetOptions ('tarball=s' => \my $tarball, |
b5bf278a A |
157 | 'version=s' => \my $version, |
158 | force => \my $force,) | |
4d18e0a2 A |
159 | or die "Failed to parse arguments"; |
160 | ||
161 | die "Usage: $0 module [args] [cpan package]" unless @ARGV == 1 || @ARGV == 2; | |
418f4069 | 162 | |
5b73aae5 A |
163 | my ($module) = shift; |
164 | my $cpan_mod = @ARGV ? shift : $module; | |
418f4069 | 165 | |
4d18e0a2 | 166 | |
418f4069 A |
167 | my $info = $Modules {$module} or die "Cannot find module $module"; |
168 | my $distribution = $$info {DISTRIBUTION}; | |
b5bf278a A |
169 | |
170 | my @files = glob $$info {FILES}; | |
b7e2b692 | 171 | if (!-d $files [0] || grep { $_ eq $module } @problematic) { |
b5bf278a A |
172 | say "This looks like a setup $0 cannot handle (yet)"; |
173 | unless ($force) { | |
174 | say "Will not continue without a --force option"; | |
175 | exit 1; | |
176 | } | |
177 | say "--force is in effect, so we'll soldier on. Wish me luck!"; | |
178 | } | |
179 | ||
180 | ||
181 | chdir "cpan"; | |
182 | ||
83d3dd1d | 183 | my $pkg_dir = $files[0]; |
418f4069 A |
184 | $pkg_dir =~ s!.*/!!; |
185 | ||
186 | my ($old_version) = $distribution =~ /-([0-9.]+)\.tar\.gz/; | |
187 | ||
188 | my $o_module = $module; | |
5b73aae5 A |
189 | if ($cpan_mod =~ /-/ && $cpan_mod !~ /::/) { |
190 | $cpan_mod =~ s/-/::/g; | |
418f4069 A |
191 | } |
192 | ||
193 | # | |
194 | # Find the information from CPAN. | |
195 | # | |
4d18e0a2 A |
196 | my $new_file; |
197 | my $new_version; | |
198 | unless ($tarball) { | |
199 | # | |
200 | # Poor man's cache | |
201 | # | |
202 | unless (-f $package_file && -M $package_file < 1) { | |
132246f2 MM |
203 | eval { |
204 | require HTTP::Tiny; | |
205 | my $http= HTTP::Tiny->new(); | |
206 | $http->mirror( $package_url => $package_file ); | |
207 | 1 | |
208 | } or system wget => $package_url, '-qO', $package_file; | |
4d18e0a2 A |
209 | } |
210 | ||
211 | my $new_line = `grep '^$cpan_mod ' $package_file` | |
212 | or die "Cannot find $cpan_mod on CPAN\n"; | |
213 | chomp $new_line; | |
214 | (undef, $new_version, my $new_path) = split ' ', $new_line; | |
3a4316cc JL |
215 | if (defined $version) { |
216 | $new_path =~ s/-$new_version\./-$version\./; | |
217 | $new_version = $version; | |
218 | } | |
4d18e0a2 A |
219 | $new_file = (split '/', $new_path) [-1]; |
220 | ||
221 | my $url = "http://search.cpan.org/CPAN/authors/id/$new_path"; | |
222 | say "Fetching $url"; | |
223 | # | |
224 | # Fetch the new distro | |
225 | # | |
132246f2 MM |
226 | eval { |
227 | require HTTP::Tiny; | |
228 | my $http= HTTP::Tiny->new(); | |
229 | $http->mirror( $url => $new_file ); | |
230 | 1 | |
231 | } or system wget => $url, '-qO', $new_file; | |
4d18e0a2 A |
232 | } |
233 | else { | |
234 | $new_file = $tarball; | |
235 | $new_version = $version // ($new_file =~ /-([0-9._]+)\.tar\.gz/) [0]; | |
236 | } | |
418f4069 A |
237 | |
238 | my $old_dir = "$pkg_dir-$old_version"; | |
418f4069 A |
239 | |
240 | say "Cleaning out old directory"; | |
241 | system git => 'clean', '-dfxq', $pkg_dir; | |
242 | ||
418f4069 | 243 | say "Unpacking $new_file"; |
5fb91d48 | 244 | Archive::Tar->extract_archive( $new_file ); |
418f4069 | 245 | |
618ac2f6 | 246 | (my $new_dir = $new_file) =~ s/\.tar\.gz//; |
3f7808eb JL |
247 | # ensure 'make' will update all files |
248 | system('find', $new_dir, '-exec', 'touch', '{}', ';'); | |
418f4069 A |
249 | |
250 | say "Renaming directories"; | |
251 | rename $pkg_dir => $old_dir; | |
418f4069 | 252 | |
83d3dd1d JL |
253 | say "Creating new package directory"; |
254 | mkdir $pkg_dir; | |
255 | ||
256 | say "Populating new package directory"; | |
257 | my $map = $$info {MAP}; | |
258 | my @EXCLUDED_QR; | |
259 | my %EXCLUDED_QQ; | |
260 | if ($$info {EXCLUDED}) { | |
261 | foreach my $entry (@{$$info {EXCLUDED}}) { | |
262 | if (ref $entry) {push @EXCLUDED_QR => $entry} | |
263 | else {$EXCLUDED_QQ {$entry} = 1} | |
264 | } | |
265 | } | |
266 | ||
267 | FILE: for my $file ( `find $new_dir -type f` ) { | |
268 | chomp $file; | |
269 | my $old_file = $file; | |
270 | $file =~ s{^$new_dir/}{}; | |
271 | ||
272 | next if $EXCLUDED_QQ{$file}; | |
273 | for my $qr (@EXCLUDED_QR) { | |
274 | next FILE if $file =~ $qr; | |
275 | } | |
276 | ||
277 | if ( $map ) { | |
278 | for my $key ( sort { length $b <=> length $a } keys %$map ) { | |
279 | my $val = $map->{$key}; | |
280 | last if $file =~ s/^$key/$val/; | |
281 | } | |
282 | } | |
7bbb137d JL |
283 | else { |
284 | $file = $files[0] . '/' . $file; | |
285 | } | |
83d3dd1d JL |
286 | |
287 | if ( $file =~ m{^cpan/} ) { | |
288 | $file =~ s{^cpan/}{}; | |
289 | } | |
290 | else { | |
291 | $file = '../' . $file; | |
292 | } | |
293 | ||
294 | my $prefix = ''; | |
295 | my @parts = split '/', $file; | |
296 | pop @parts; | |
297 | for my $part (@parts) { | |
298 | $prefix .= '/' if $prefix; | |
299 | $prefix .= $part; | |
300 | mkdir $prefix unless -d $prefix; | |
301 | } | |
302 | ||
303 | rename $old_file => $file; | |
304 | } | |
192f56b0 | 305 | remove_tree( $new_dir ); |
418f4069 A |
306 | |
307 | if (-f "$old_dir/.gitignore") { | |
308 | say "Restoring .gitignore"; | |
309 | system git => 'checkout', "$pkg_dir/.gitignore"; | |
310 | } | |
311 | ||
ad9b4e6f | 312 | my @new_files = `find $pkg_dir -type f`; |
418f4069 A |
313 | chomp @new_files; |
314 | @new_files = grep {$_ ne $pkg_dir} @new_files; | |
315 | s!^[^/]+/!! for @new_files; | |
316 | my %new_files = map {$_ => 1} @new_files; | |
317 | ||
ad9b4e6f | 318 | my @old_files = `find $old_dir -type f`; |
418f4069 A |
319 | chomp @old_files; |
320 | @old_files = grep {$_ ne $old_dir} @old_files; | |
321 | s!^[^/]+/!! for @old_files; | |
322 | my %old_files = map {$_ => 1} @old_files; | |
323 | ||
418f4069 A |
324 | my @delete; |
325 | my @commit; | |
326 | my @gone; | |
418f4069 A |
327 | FILE: |
328 | foreach my $file (@new_files) { | |
329 | next if -d "$pkg_dir/$file"; # Ignore directories. | |
330 | next if $old_files {$file}; # It's already there. | |
331 | if ($IGNORABLE {$file}) { | |
332 | push @delete => $file; | |
333 | next; | |
334 | } | |
418f4069 A |
335 | push @commit => $file; |
336 | } | |
337 | foreach my $file (@old_files) { | |
338 | next if -d "$old_dir/$file"; | |
339 | next if $new_files {$file}; | |
340 | push @gone => $file; | |
341 | } | |
ad9b4e6f A |
342 | |
343 | # | |
344 | # Find all files with an exec bit | |
345 | # | |
346 | my @exec = `find $pkg_dir -type f -perm +111`; | |
418f4069 | 347 | chomp @exec; |
ad9b4e6f A |
348 | my @de_exec; |
349 | foreach my $file (@exec) { | |
350 | # Remove leading dir | |
351 | $file =~ s!^[^/]+/!!; | |
352 | if ($file =~ m!^t/!) { | |
353 | push @de_exec => $file; | |
354 | next; | |
355 | } | |
356 | # Check to see if the file exists; if it doesn't and doesn't have | |
357 | # the exec bit, remove it. | |
358 | if ($old_files {$file}) { | |
359 | unless (-x "$old_dir/$file") { | |
360 | push @de_exec => $file; | |
361 | } | |
362 | } | |
363 | } | |
418f4069 A |
364 | |
365 | # | |
366 | # No need to change the +x bit on files that will be deleted. | |
367 | # | |
ad9b4e6f | 368 | if (@de_exec && @delete) { |
a9f5d1d4 | 369 | my %delete = map {+"$pkg_dir/$_" => 1} @delete; |
ad9b4e6f | 370 | @de_exec = grep {!$delete {$_}} @de_exec; |
418f4069 A |
371 | } |
372 | ||
373 | say "unlink $pkg_dir/$_" for @delete; | |
374 | say "git add $pkg_dir/$_" for @commit; | |
375 | say "git rm -f $pkg_dir/$_" for @gone; | |
ad9b4e6f | 376 | say "chmod a-x $pkg_dir/$_" for @de_exec; |
418f4069 A |
377 | |
378 | print "Hit return to continue; ^C to abort "; <STDIN>; | |
379 | ||
380 | unlink "$pkg_dir/$_" for @delete; | |
381 | system git => 'add', "$pkg_dir/$_" for @commit; | |
382 | system git => 'rm', '-f', "$pkg_dir/$_" for @gone; | |
ad9b4e6f | 383 | system chmod => 'a-x', "$pkg_dir/$_" for @de_exec; |
418f4069 | 384 | |
9c259538 A |
385 | # |
386 | # Restore anything that is customized. | |
387 | # We don't really care whether we've deleted the file - since we | |
388 | # do a git restore, it's going to be resurrected if necessary. | |
389 | # | |
390 | if ($$info {CUSTOMIZED}) { | |
391 | say "Restoring customized files"; | |
392 | foreach my $file (@{$$info {CUSTOMIZED}}) { | |
393 | system git => "checkout", "$pkg_dir/$file"; | |
394 | } | |
395 | } | |
396 | ||
a8121781 | 397 | chdir ".."; |
418f4069 A |
398 | if (@commit) { |
399 | say "Fixing MANIFEST"; | |
a8121781 | 400 | my $MANIFEST = "MANIFEST"; |
418f4069 A |
401 | my $MANIFEST_SORT = "$MANIFEST.sorted"; |
402 | open my $fh, ">>", $MANIFEST; | |
a8121781 | 403 | say $fh "cpan/$pkg_dir/$_" for @commit; |
418f4069 | 404 | close $fh; |
a8121781 | 405 | system perl => "Porting/manisort", '--output', $MANIFEST_SORT; |
418f4069 A |
406 | rename $MANIFEST_SORT => $MANIFEST; |
407 | } | |
408 | ||
409 | ||
418f4069 A |
410 | print "Running a make ... "; |
411 | system "make > make.log 2>&1" and die "Running make failed, see make.log"; | |
412 | print "done\n"; | |
413 | ||
414 | # | |
415 | # Must clean up, or else t/porting/FindExt.t will fail. | |
730ad6b9 | 416 | # Note that we can always retrieve the original directory with a git checkout. |
418f4069 A |
417 | # |
418 | print "About to clean up; hit return or abort (^C) "; <STDIN>; | |
419 | ||
192f56b0 MM |
420 | remove_tree( "cpan/$old_dir" ); |
421 | unlink "cpan/$new_file" unless $tarball; | |
418f4069 A |
422 | |
423 | ||
ad9b4e6f A |
424 | # |
425 | # Run the tests. First the test belonging to the module, followed by the | |
426 | # the tests in t/porting | |
427 | # | |
192f56b0 | 428 | chdir "t"; |
ad9b4e6f A |
429 | say "Running module tests"; |
430 | my @test_files = `find ../cpan/$pkg_dir -name '*.t' -type f`; | |
431 | chomp @test_files; | |
432 | my $output = `./perl TEST @test_files`; | |
433 | unless ($output =~ /All tests successful/) { | |
434 | say $output; | |
435 | exit 1; | |
436 | } | |
437 | ||
418f4069 A |
438 | print "Running tests in t/porting "; |
439 | my @tests = `ls porting/*.t`; | |
440 | chomp @tests; | |
441 | my @failed; | |
442 | foreach my $t (@tests) { | |
443 | my @not = `./perl -I../lib -I.. $t | grep ^not | grep -v "# TODO"`; | |
444 | print @not ? '!' : '.'; | |
445 | push @failed => $t if @not; | |
446 | } | |
447 | print "\n"; | |
448 | say "Failed tests: @failed" if @failed; | |
449 | ||
450 | ||
9807c17b JL |
451 | say "Attempting to update Maintainers.pl"; |
452 | chdir '..'; | |
453 | ||
454 | open my $Maintainers_pl, '<', 'Porting/Maintainers.pl'; | |
455 | open my $new_Maintainers_pl, '>', 'Maintainers.pl'; | |
456 | ||
457 | my $found; | |
458 | my $in_mod_section; | |
459 | while (<$Maintainers_pl>) { | |
460 | if (!$found) { | |
461 | if ($in_mod_section) { | |
462 | if (/DISTRIBUTION/) { | |
33c6567b | 463 | if (s/\Q$old_version/$new_version/) { |
9807c17b JL |
464 | $found = 1; |
465 | } | |
466 | } | |
467 | ||
468 | if (/^ }/) { | |
469 | $in_mod_section = 0; | |
470 | } | |
471 | } | |
472 | ||
473 | if (/\Q$cpan_mod/) { | |
474 | $in_mod_section = 1; | |
475 | } | |
476 | } | |
477 | ||
478 | print $new_Maintainers_pl $_; | |
479 | } | |
480 | ||
481 | if ($found) { | |
482 | unlink 'Porting/Maintainers.pl'; | |
483 | rename 'Maintainers.pl' => 'Porting/Maintainers.pl'; | |
484 | system chmod => 'a+x', 'Porting/Maintainers.pl'; | |
485 | } | |
486 | else { | |
487 | say "Could not update Porting/Maintainers.pl."; | |
488 | say "Make sure you update this by hand before committing."; | |
489 | } | |
418f4069 | 490 | |
418f4069 | 491 | say "$o_module is now version $new_version"; |
9807c17b | 492 | say "Now you ought to run a make; make test ..."; |
418f4069 A |
493 | |
494 | ||
495 | __END__ |