use Getopt::Std;
+use Cwd;
use File::Path;
use File::Copy;
use File::Spec;
+use Scalar::Util;
use Time::HiRes;
use Module::CoreList;
+use CPAN::Perl::Releases;
use version;
-use File::Fetch;
+use LWP::UserAgent;
use Archive::Extract;
-my $has_cpan_perl_releases;
BEGIN {
- local $@;
- if (eval { require CPAN::Perl::Releases; 1 }) {
- print "Will use CPAN::Perl::Releases\n";
- $has_cpan_perl_releases = 1;
- }
+ my $old_fh = select STDOUT;
+ $|++;
+ select $old_fh;
}
my %opts;
sub new {
my $class = shift;
-
+
my %args = @_;
my ($path, $indent, $keep) = @args{qw<path indent keep>};
die "Path $path already exists" if -e $path;
File::Path::mkpath($path);
-
+
bless {
path => $path,
indent => $indent || 0,
}
sub key_version {
- my $v = shift;
+ my $num_version = shift;
- my $obj = version->parse($v);
- my $version = $obj->normal;
- $version =~ s/^v?//;
+ my $obj = version->parse($num_version);
+ my $pretty_version = $obj->normal;
+ $pretty_version =~ s/^v?//;
- my ($int, $frac) = split /\./, $v, 2;
+ my ($int, $frac) = split /\./, $num_version, 2;
die 'Wrong fractional part' if length $frac > 6;
$frac .= '0' x (6 - length $frac);
- "$int$frac" => $version;
+ "$int$frac" => [ $num_version, $pretty_version ];
}
my %perls = map key_version($_),
grep "$_" >= '5.010001',
keys %Module::CoreList::released;
+{
+ package LWP::MyUserAgent;
+
+ our @ISA;
+ BEGIN { push @ISA, 'LWP::UserAgent' }
+
+ my %cbs;
+ my %ticks;
+
+ sub new {
+ my ($class, $cb) = @_;
+
+ my $ua = bless LWP::UserAgent->new, $class;
+ $ua->timeout(10);
+ $ua->show_progress(1) if $cb;
+
+ my $tag = Scalar::Util::refaddr($ua);
+ $cbs{$tag} = $cb;
+ $ticks{$tag} = 0;
+
+ return $ua;
+ }
+
+ sub progress {
+ my ($ua, $stat, $r) = @_;
+
+ my $tag = Scalar::Util::refaddr($ua);
+ my $cb = $cbs{$tag};
+ return unless $cb;
+
+ my $desc;
+ if ($stat eq 'begin') {
+ $desc = '...';
+ } elsif ($stat eq 'end') {
+ $desc = 'done';
+ } elsif ($stat eq 'tick') {
+ my $tick = ++$ticks{$tag};
+ $desc = qw<- \ | />[$tick % 4];
+ } else {
+ $desc = sprintf "%.01f%%", 100 * $stat;
+ }
+
+ $cb->($stat, $desc);
+
+ return;
+ }
+
+ sub DESTROY {
+ my $ua = shift;
+
+ my $tag = Scalar::Util::refaddr($ua);
+
+ delete $cbs{$tag};
+ delete $ticks{$tag};
+
+ return;
+ }
+}
+
sub fetch_uri {
- my ($uri, $to) = @_;
+ my ($uri, $to, $cb) = @_;
my $start = [ Time::HiRes::gettimeofday ];
- my $ff = File::Fetch->new(uri => $uri);
- my $file = $ff->fetch(to => $to) or die "Could not fetch $uri: " . $ff->error;
+ my $ua = LWP::MyUserAgent->new($cb);
+ my $res = $ua->get($uri);
+ die "Could not fetch $uri: " . $res->status_line unless $res->is_success;
+
+ my $here = Cwd::cwd;
+ my $file = (File::Spec::Unix->splitpath(URI->new($uri)->path))[2];
+ my $vol = (File::Spec->splitpath($here))[0];
+ $to = File::Spec->catdir($here, $to)
+ unless File::Spec->file_name_is_absolute($to);
+ $file = File::Spec->catpath($vol, $to, $file);
+
+ open my $fh, '>', $file or die "Can't open $file for writing: $!";
+ print $fh $res->content;
+ close $fh or die "Can't close $file: $!";
my $elapsed = Time::HiRes::tv_interval($start);
sub perl_archive_for {
my $version = shift;
- my $path;
-
- if ($has_cpan_perl_releases) {
- my $tarballs = CPAN::Perl::Releases::perl_tarballs($version);
-
- if (defined $tarballs) {
- $path = $tarballs->{'tar.gz'};
- }
- } else {
- my $uri = "http://search.cpan.org/dist/perl-$version";
-
- local $_;
- fetch_uri($uri => \$_);
+ my $tarballs = CPAN::Perl::Releases::perl_tarballs($version);
+ my $path = $tarballs->{'tar.gz'};
+ die "Could not find the archive for perl $version" unless defined $path;
- if (m{id/(([^/])/\2([^/])/\2\3[^/]*/perl-\Q$version\E\.tar\.(?:gz|bz2))}) {
- $path = $1;
- }
- }
+ my ($file) = ($path =~ m{([^/]*)$});
- if (defined $path) {
- my ($file) = ($path =~ m{([^/]*)$});
- return "http://$cpan_mirror/authors/id/$path", $file;
- } else {
- die "Could not infer the archive for perl $version";
- }
+ return "http://$cpan_mirror/authors/id/$path", $file;
}
sub bandwidth {
if (-e File::Spec->catfile($tmp_dir, $archive_file)) {
print "${INDENT}$archive_file was already fetched\n";
} else {
- print "${INDENT}Fetching $archive_uri... ";
- ($archive_file, my $elapsed) = fetch_uri($archive_uri => $tmp_dir);
+ print "${INDENT}Fetching $archive_uri...\n";
+ my $maxlen = 0;
+ my $cb = sub {
+ my ($stat, $desc) = @_;
+ $desc = '0%' if $stat eq 'begin';
+ my $len = length $desc;
+ my $extra = '';
+ if ($len > $maxlen) {
+ $maxlen = $len;
+ } else {
+ $extra = ' ' x ($maxlen - $len);
+ }
+ print "\r${INDENT} In progress... $desc$extra";
+ print "$extra\n" if $stat eq 'end';
+ };
+ ($archive_file, my $elapsed) = fetch_uri($archive_uri => $tmp_dir, $cb);
my ($speed, $unit) = bandwidth(-s $archive_file, $elapsed);
- print "done at $speed$unit\n";
+ print "${INDENT} File downloaded at $speed$unit\n";
}
my $extract_path = File::Spec->catfile($tmp_dir, "perl-$version");
my %patched_chunks;
my %expected_chunks = (
- 'regcomp.c' => [ qw<re_defs COMP_BEGIN_HOOK>, ('COMP_NODE_HOOK') x 3 ],
- 'regexec.c' => [ qw<re_defs EXEC_NODE_HOOK> ],
+ 'regcomp.c' => [
+ 're_defs',
+ 'COMP_NODE_HOOK',
+ 'COMP_BEGIN_HOOK',
+ ('COMP_NODE_HOOK') x 3,
+ ],
+ 'regexec.c' => [
+ 're_defs',
+ 'EXEC_NODE_HOOK',
+ ],
);
sub patch_regcomp {
my $shift = $1 ? 2 : 1;
push @{$patched_chunks{$file}}, 'COMP_NODE_HOOK';
return $line, " REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, ($2) - $shift);\n"
+ } elsif ($line =~ /end node insert/) {
+ push @{$patched_chunks{$file}}, 'COMP_NODE_HOOK';
+ return $line, " REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, convert);\n";
+ } elsif ($line =~ /&PL_core_reg_engine/) {
+ $line =~ s/&PL_core_reg_engine\b/&reh_regexp_engine/g;
+ return $line;
}
return $line;
}
for my $tag (sort { $a <=> $b } keys %perls) {
- my $version = $perls{$tag};
+ my ($num_version, $pretty_version) = @{$perls{$tag}};
my $dir = File::Spec->catdir($target, $tag);
- print "Working on perl $version\n";
+ print "Working on perl $pretty_version\n";
my $tmp_guard = Guard::Path->new(path => $tmp_dir);
my $orig_dir = File::Spec->catdir($dir, 'orig');
- my @files = qw<regcomp.c regexec.c dquote_static.c>;
+
+ my @files = qw<regcomp.c regexec.c>;
+ push @files, 'dquote_static.c' if $num_version >= 5.013_006;
+ push @files, 'inline_invlist.c' if $num_version >= 5.017_004;
for my $file (@files) {
my $orig_file = File::Spec->catfile($orig_dir, $file);
if (-e $orig_file) {
print " Already have original $file\n";
} else {
print " Need to get original $file\n";
- fetch_source_file($file, $version => $orig_dir);
+ fetch_source_file($file, $pretty_version => $orig_dir);
}
if (-s $orig_file) {
print $out sort @manifest_files, @source_files;
print "done\n";
-}
+}