Fix infinite recursion with perl 5.17.[12]

[perl/modules/re-engine-Hooks.git] / src / update.pl

diff --git a/src/update.pl b/src/update.pl
index 53836074173c9ee5dff477bb602bbd77427f60f1..e7fe628cf087fd93efb56a05bb5be044ec1e9263 100644 (file)
--- a/src/update.pl
+++ b/src/update.pl
@@ -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,18 +82,18 @@ 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 %perls = map key_version($_),
@@ -216,28 +216,53 @@ sub fetch_source_file {
  }
 }
 
+my %patched_chunks;
+my %expected_chunks = (
+ '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 $line = $_[0];
+ my ($line, $file) = @_;
 
  if ($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*$/) {
+  push @{$patched_chunks{$file}}, 'COMP_BEGIN_HOOK';
   return $line, "$1REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);\n";
  } elsif ($line =~ /FILL_ADVANCE_NODE(_ARG)?\(\s*([^\s,\)]+)/) {
   my $shift = $1 ? 2 : 1;
-  return $line, "    REH_CALL_REGCOMP_HOOK(pRExC_state->rx, ($2) - $shift);\n"
+  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;
 }
 
 sub patch_regexec {
- my $line = $_[0];
+ my ($line, $file) = @_;
 
  if ($line =~ /#\s*include\s+"perl\.h"/) {
+  push @{$patched_chunks{$file}}, 're_defs';
   return $line, "#include \"re_defs.h\"\n";
  } elsif ($line =~ /^\s*reenter_switch:\s*$/) {
-  return "\tREH_CALL_REGEXEC_HOOK(rex, scan, reginfo, st);\n", $line;
+  push @{$patched_chunks{$file}}, 'EXEC_NODE_HOOK';
+  return "\tREH_CALL_EXEC_NODE_HOOK(rex, scan, reginfo, st);\n", $line;
  }
 
  return $line;
@@ -266,30 +291,39 @@ 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);
+  print $out $mangler->($line, $dst);
+ }
+
+ 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";
  }
 
  return 1;
 }
 
 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) {
@@ -319,4 +353,4 @@ for my $tag (sort { $a <=> $b } keys %perls) {
  print $out sort @manifest_files, @source_files;
 
  print "done\n";
-} 
+}