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

diff --git a/src/update.pl b/src/update.pl
index fb4c25c..1b5834e 100644
--- a/src/update.pl
+++ b/src/update.pl
@@ -14,6 +14,7 @@ use Scalar::Util;
 use Time::HiRes;
 
 use Module::CoreList;
+use CPAN::Perl::Releases;
 use version;
 
 use LWP::UserAgent;
@@ -25,15 +26,6 @@ BEGIN {
  select $old_fh;
 }
 
-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 %opts;
 getopts('ft:m:', \%opts);
 
@@ -104,8 +96,22 @@ sub key_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;
 
 {
@@ -195,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);
+ 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 (defined $tarballs) {
-   $path = $tarballs->{'tar.gz'};
-  }
- } else {
-  my $uri = "http://search.cpan.org/dist/perl-$version";
+ my ($file) = ($path =~ m{([^/]*)$});
 
-  local $_;
-  fetch_uri($uri => \$_);
-
-  if (m{id/(([^/])/\2([^/])/\2\3[^/]*/perl-\Q$version\E\.tar\.(?:gz|bz2))}) {
-   $path = $1;
-  }
- }
-
- 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 {
@@ -312,13 +300,14 @@ sub fetch_source_file {
 my %patched_chunks;
 my %expected_chunks = (
  'regcomp.c' => [
+  'PERL_IN_XSUB_RE',
   're_defs',
   'COMP_NODE_HOOK',
   'COMP_BEGIN_HOOK',
   ('COMP_NODE_HOOK') x 3,
  ],
  'regexec.c' => [
-  're_defs',
+  'PERL_IN_XSUB_RE+re_defs',
   'EXEC_NODE_HOOK',
  ],
 );
@@ -326,7 +315,15 @@ my %expected_chunks = (
 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*$/) {
@@ -351,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;
@@ -362,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 {
@@ -384,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";
  }