X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=src%2Fupdate.pl;h=1b5834e3045c6544635e9f71aec363a6c97949b9;hb=HEAD;hp=a36c99d376cc9316a421a14086dc61c46dd2472b;hpb=3873fbc39d250734131e096da47add0cf601d194;p=perl%2Fmodules%2Fre-engine-Hooks.git

diff --git a/src/update.pl b/src/update.pl
index a36c99d..1b5834e 100644
--- a/src/update.pl
+++ b/src/update.pl
@@ -5,25 +5,25 @@ use warnings;
 
 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;
@@ -43,13 +43,13 @@ local $SIG{'INT'} = sub { exit 1 };
 
  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,
@@ -82,31 +82,116 @@ local $SIG{'INT'} = sub { exit 1 };
 }
 
 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 $latest_dev_rev = 23;
+
+sub perl_is_supported {
+ my $v = "$_[0]";
+
+ return unless $v >= '5.010001';
+
+ if ($v =~ /^5\.([0-9]{2}[13579])/) {
+  return $1 >= $latest_dev_rev;
+ }
+
+ return 1;
 }
 
 my %perls = map key_version($_),
-             grep "$_" >= '5.010001',
+             grep perl_is_supported($_),
               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);
 
@@ -116,31 +201,13 @@ sub fetch_uri {
 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 {
@@ -183,10 +250,24 @@ sub fetch_source_file {
  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");
@@ -218,14 +299,31 @@ sub fetch_source_file {
 
 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' => [
+  'PERL_IN_XSUB_RE',
+  're_defs',
+  'COMP_NODE_HOOK',
+  'COMP_BEGIN_HOOK',
+  ('COMP_NODE_HOOK') x 3,
+ ],
+ 'regexec.c' => [
+  'PERL_IN_XSUB_RE+re_defs',
+  'EXEC_NODE_HOOK',
+ ],
 );
 
 sub patch_regcomp {
  my ($line, $file) = @_;
 
- if ($line =~ /#\s*include\s+"INTERN\.h"/) {
+ if ($line =~ /#\s*include\s+"perl\.h"/) {
+  push @{$patched_chunks{$file}}, 'PERL_IN_XSUB_RE';
+  return (
+   "#undef PERL_IN_XSUB_RE\n",
+   "#define PERL_IN_XSUB_RE 1\n",
+   $line,
+   "#undef PERL_IN_XSUB_RE\n",
+  );
+ } elsif ($line =~ /#\s*include\s+"INTERN\.h"/) {
   push @{$patched_chunks{$file}}, 're_defs';
   return "#include \"re_defs.h\"\n";
  } elsif ($line =~ /^(\s*)RExC_rxi\s*=\s*ri\s*;\s*$/) {
@@ -235,6 +333,12 @@ 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;
@@ -244,8 +348,14 @@ sub patch_regexec {
  my ($line, $file) = @_;
 
  if ($line =~ /#\s*include\s+"perl\.h"/) {
-  push @{$patched_chunks{$file}}, 're_defs';
-  return $line, "#include \"re_defs.h\"\n";
+  push @{$patched_chunks{$file}}, 'PERL_IN_XSUB_RE+re_defs';
+  return (
+   "#undef PERL_IN_XSUB_RE\n",
+   "#define PERL_IN_XSUB_RE 1\n",
+   $line,
+   "#include \"re_defs.h\"\n",
+   "#undef PERL_IN_XSUB_RE\n",
+  );
  } elsif ($line =~ /^\s*reenter_switch:\s*$/) {
   push @{$patched_chunks{$file}}, 'EXEC_NODE_HOOK';
   return "\tREH_CALL_EXEC_NODE_HOOK(rex, scan, reginfo, st);\n", $line;
@@ -255,8 +365,10 @@ sub patch_regexec {
 }
 
 my %manglers = (
- 'regcomp.c' => \&patch_regcomp,
- 'regexec.c' => \&patch_regexec,
+ 'dquote_static.c'  => sub { $_[0] },
+ 'inline_invlist.c' => sub { $_[0] },
+ 'regcomp.c'        => \&patch_regcomp,
+ 'regexec.c'        => \&patch_regexec,
 );
 
 sub patch_source_file {
@@ -277,11 +389,20 @@ sub patch_source_file {
  open my $out, '>', $dst or die "Can't open $dst for writing: $!";
 
  while (defined(my $line = <$in>)) {
-  print $out $mangler->($line, $dst);
+  my @lines = $mangler->($line, $dst);
+
+  for (@lines) {
+   s/\s*$/\n/;                         # Remove trailing whitespace
+   1 while s/^( *)\t/$1 . (' ' x 8)/e; # Replace leading tabs by 8 spaces
+   s|^((?:    )+) {0,3}([^ ])|(' ' x ((length $1) / 4)) . $2|e;
+   s/\t/ /g;
+  }
+
+  print $out @lines;
  }
 
- my $patched_chunks  = join ' ', @{$patched_chunks{$dst}};
- my $expected_chunks = join ' ', @{$expected_chunks{$file}};
+ my $patched_chunks  = join ' ', @{$patched_chunks{$dst}   || [ ]};
+ my $expected_chunks = join ' ', @{$expected_chunks{$file} || [ ]};
  unless ($patched_chunks eq $expected_chunks) {
   die "File $dst was not properly patched (got \"$patched_chunks\", expected \"$expected_chunks\")\n";
  }
@@ -290,23 +411,26 @@ sub patch_source_file {
 }
 
 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) {
@@ -336,4 +460,4 @@ for my $tag (sort { $a <=> $b } keys %perls) {
  print $out sort @manifest_files, @source_files;
 
  print "done\n";
-} 
+}