17 use CPAN::Perl::Releases;
24 my $old_fh = select STDOUT;
30 getopts('ft:m:', \%opts);
32 my $cpan_mirror = 'cpan.cpantesters.org';
39 local $SIG{'INT'} = sub { exit 1 };
48 my ($path, $indent, $keep) = @args{qw<path indent keep>};
50 die "Path $path already exists" if -e $path;
51 File::Path::mkpath($path);
55 indent => $indent || 0,
62 eval "sub $_ { \$_[0]->{$_} }; 1" or die $@ for qw<path indent>;
65 sub keep { @_ > 1 ? $_[0]->{keep} = $_[1] : $_[0]->{keep} }
70 return if $self->keep;
72 my $path = $self->path;
73 return unless -e $path;
75 my $indent = $self->indent;
76 $indent = ' ' x (2 * $indent);
78 print "${indent}Cleaning up path $path... ";
79 File::Path::remove_tree($path);
85 my $num_version = shift;
87 my $obj = version->parse($num_version);
88 my $pretty_version = $obj->normal;
89 $pretty_version =~ s/^v?//;
91 my ($int, $frac) = split /\./, $num_version, 2;
93 die 'Wrong fractional part' if length $frac > 6;
94 $frac .= '0' x (6 - length $frac);
96 "$int$frac" => [ $num_version, $pretty_version ];
99 my $latest_dev_rev = 23;
101 sub perl_is_supported {
104 return unless $v >= '5.010001';
106 if ($v =~ /^5\.([0-9]{2}[13579])/) {
107 return $1 >= $latest_dev_rev;
113 my %perls = map key_version($_),
114 grep perl_is_supported($_),
115 keys %Module::CoreList::released;
118 package LWP::MyUserAgent;
121 BEGIN { push @ISA, 'LWP::UserAgent' }
127 my ($class, $cb) = @_;
129 my $ua = bless LWP::UserAgent->new, $class;
131 $ua->show_progress(1) if $cb;
133 my $tag = Scalar::Util::refaddr($ua);
141 my ($ua, $stat, $r) = @_;
143 my $tag = Scalar::Util::refaddr($ua);
148 if ($stat eq 'begin') {
150 } elsif ($stat eq 'end') {
152 } elsif ($stat eq 'tick') {
153 my $tick = ++$ticks{$tag};
154 $desc = qw<- \ | />[$tick % 4];
156 $desc = sprintf "%.01f%%", 100 * $stat;
167 my $tag = Scalar::Util::refaddr($ua);
177 my ($uri, $to, $cb) = @_;
179 my $start = [ Time::HiRes::gettimeofday ];
181 my $ua = LWP::MyUserAgent->new($cb);
182 my $res = $ua->get($uri);
183 die "Could not fetch $uri: " . $res->status_line unless $res->is_success;
186 my $file = (File::Spec::Unix->splitpath(URI->new($uri)->path))[2];
187 my $vol = (File::Spec->splitpath($here))[0];
188 $to = File::Spec->catdir($here, $to)
189 unless File::Spec->file_name_is_absolute($to);
190 $file = File::Spec->catpath($vol, $to, $file);
192 open my $fh, '>', $file or die "Can't open $file for writing: $!";
193 print $fh $res->content;
194 close $fh or die "Can't close $file: $!";
196 my $elapsed = Time::HiRes::tv_interval($start);
198 return $file, $elapsed;
201 sub perl_archive_for {
204 my $tarballs = CPAN::Perl::Releases::perl_tarballs($version);
205 my $path = $tarballs->{'tar.gz'};
206 die "Could not find the archive for perl $version" unless defined $path;
208 my ($file) = ($path =~ m{([^/]*)$});
210 return "http://$cpan_mirror/authors/id/$path", $file;
214 my ($size, $seconds) = @_;
216 my $speed = $size / $seconds;
219 while ($speed >= 1024) {
224 $speed = sprintf '%.02f', $speed;
226 my $unit = ('', 'K', 'M', 'G', 'T', 'P')[$order] . 'B/s';
228 return $speed, $unit;
234 open my $fh, '>', $file or die "Can't open $file for writing: $!";
237 File::Path::mkpath($target) unless -e $target;
239 my $tmp_dir = File::Spec->catdir($target, 'tmp');
241 sub fetch_source_file {
242 my ($file, $version, $dir) = @_;
244 my $INDENT = ' ' x 4;
246 print "${INDENT}Looking for the full name of the perl archive... ";
247 my ($archive_uri, $archive_file) = perl_archive_for($version);
248 print "$archive_uri\n";
250 if (-e File::Spec->catfile($tmp_dir, $archive_file)) {
251 print "${INDENT}$archive_file was already fetched\n";
253 print "${INDENT}Fetching $archive_uri...\n";
256 my ($stat, $desc) = @_;
257 $desc = '0%' if $stat eq 'begin';
258 my $len = length $desc;
260 if ($len > $maxlen) {
263 $extra = ' ' x ($maxlen - $len);
265 print "\r${INDENT} In progress... $desc$extra";
266 print "$extra\n" if $stat eq 'end';
268 ($archive_file, my $elapsed) = fetch_uri($archive_uri => $tmp_dir, $cb);
269 my ($speed, $unit) = bandwidth(-s $archive_file, $elapsed);
270 print "${INDENT} File downloaded at $speed$unit\n";
273 my $extract_path = File::Spec->catfile($tmp_dir, "perl-$version");
274 if (-e $extract_path) {
275 print "${INDENT}$archive_file was already extracted\n";
277 print "${INDENT}Extracting $archive_file... ";
278 my $ae = Archive::Extract->new(archive => $archive_file);
279 $ae->extract(to => $tmp_dir)
280 or die "Could not extract $archive_file: " . $ae->error;
281 $extract_path = $ae->extract_path;
285 File::Path::mkpath($dir) unless -e $dir;
286 print "${INDENT}Copying $file to $dir... ";
287 my $src = File::Spec->catfile($extract_path, $file);
288 my $dst = File::Spec->catfile($dir, $file);
290 File::Copy::copy($src => $dst) or die "Can't copy $src to $dst: $!";
295 print "not needed\n";
301 my %expected_chunks = (
307 ('COMP_NODE_HOOK') x 3,
310 'PERL_IN_XSUB_RE+re_defs',
316 my ($line, $file) = @_;
318 if ($line =~ /#\s*include\s+"perl\.h"/) {
319 push @{$patched_chunks{$file}}, 'PERL_IN_XSUB_RE';
321 "#undef PERL_IN_XSUB_RE\n",
322 "#define PERL_IN_XSUB_RE 1\n",
324 "#undef PERL_IN_XSUB_RE\n",
326 } elsif ($line =~ /#\s*include\s+"INTERN\.h"/) {
327 push @{$patched_chunks{$file}}, 're_defs';
328 return "#include \"re_defs.h\"\n";
329 } elsif ($line =~ /^(\s*)RExC_rxi\s*=\s*ri\s*;\s*$/) {
330 push @{$patched_chunks{$file}}, 'COMP_BEGIN_HOOK';
331 return $line, "$1REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);\n";
332 } elsif ($line =~ /FILL_ADVANCE_NODE(_ARG)?\(\s*([^\s,\)]+)/) {
333 my $shift = $1 ? 2 : 1;
334 push @{$patched_chunks{$file}}, 'COMP_NODE_HOOK';
335 return $line, " REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, ($2) - $shift);\n"
336 } elsif ($line =~ /end node insert/) {
337 push @{$patched_chunks{$file}}, 'COMP_NODE_HOOK';
338 return $line, " REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, convert);\n";
339 } elsif ($line =~ /&PL_core_reg_engine/) {
340 $line =~ s/&PL_core_reg_engine\b/&reh_regexp_engine/g;
348 my ($line, $file) = @_;
350 if ($line =~ /#\s*include\s+"perl\.h"/) {
351 push @{$patched_chunks{$file}}, 'PERL_IN_XSUB_RE+re_defs';
353 "#undef PERL_IN_XSUB_RE\n",
354 "#define PERL_IN_XSUB_RE 1\n",
356 "#include \"re_defs.h\"\n",
357 "#undef PERL_IN_XSUB_RE\n",
359 } elsif ($line =~ /^\s*reenter_switch:\s*$/) {
360 push @{$patched_chunks{$file}}, 'EXEC_NODE_HOOK';
361 return "\tREH_CALL_EXEC_NODE_HOOK(rex, scan, reginfo, st);\n", $line;
368 'dquote_static.c' => sub { $_[0] },
369 'inline_invlist.c' => sub { $_[0] },
370 'regcomp.c' => \&patch_regcomp,
371 'regexec.c' => \&patch_regexec,
374 sub patch_source_file {
375 my ($src, $dst) = @_;
377 my $file = (File::Spec->splitpath($src))[2];
379 $dst = File::Spec->catfile($dst, $file);
382 my $mangler = $manglers{$file};
384 File::Copy::copy($src => $dst) or die "Can't copy $src to $dst: $!";
388 open my $in, '<', $src or die "Can't open $src for reading: $!";
389 open my $out, '>', $dst or die "Can't open $dst for writing: $!";
391 while (defined(my $line = <$in>)) {
392 my @lines = $mangler->($line, $dst);
395 s/\s*$/\n/; # Remove trailing whitespace
396 1 while s/^( *)\t/$1 . (' ' x 8)/e; # Replace leading tabs by 8 spaces
397 s|^((?: )+) {0,3}([^ ])|(' ' x ((length $1) / 4)) . $2|e;
404 my $patched_chunks = join ' ', @{$patched_chunks{$dst} || [ ]};
405 my $expected_chunks = join ' ', @{$expected_chunks{$file} || [ ]};
406 unless ($patched_chunks eq $expected_chunks) {
407 die "File $dst was not properly patched (got \"$patched_chunks\", expected \"$expected_chunks\")\n";
413 for my $tag (sort { $a <=> $b } keys %perls) {
414 my ($num_version, $pretty_version) = @{$perls{$tag}};
416 my $dir = File::Spec->catdir($target, $tag);
418 print "Working on perl $pretty_version\n";
420 my $tmp_guard = Guard::Path->new(path => $tmp_dir);
422 my $orig_dir = File::Spec->catdir($dir, 'orig');
424 my @files = qw<regcomp.c regexec.c>;
425 push @files, 'dquote_static.c' if $num_version >= 5.013_006;
426 push @files, 'inline_invlist.c' if $num_version >= 5.017_004;
427 for my $file (@files) {
428 my $orig_file = File::Spec->catfile($orig_dir, $file);
430 print " Already have original $file\n";
432 print " Need to get original $file\n";
433 fetch_source_file($file, $pretty_version => $orig_dir);
437 if (not $opts{f} and -e File::Spec->catfile($dir, $file)) {
438 print " Already have patched $file\n";
440 print " Need to patch $file... ";
441 my $res = patch_source_file($orig_file => $dir);
442 print $res ? "done\n" : "nothing to do\n";
449 print 'Updating MANIFEST... ';
453 open my $in, '<', 'MANIFEST' or die "Can't open MANIFEST for reading: $!";
454 @manifest_files = grep !m{^src/.*\.c$}, <$in>;
457 my @source_files = map "$_\n", glob 'src/*/*.c';
459 open my $out, '>', 'MANIFEST' or die "Can't open MANIFEST for writing: $!";
460 print $out sort @manifest_files, @source_files;