t/re/reg_eval.t

   1 #!./perl
   2
   3 # This is a test for bugs in (?{ }) and (??{ }) caused by corrupting the regex
   4 # engine state within the eval-ed code
   5 # --rafl
   6
   7 BEGIN {
   8     chdir 't' if -d 't';
   9     require './test.pl';
  10 }
  11
  12 fresh_perl_is(<<'CODE', 'ok', {});
  13 '42' =~ /4(?{ 'foo' =~ m{(foo)} })2/
  14     and print 'ok';
  15 CODE
  16
  17 fresh_perl_is(<<'CODE', 'ok', {}, 'RT#33936');
  18 'aba' =~ /(??{join('',split(qr{(?=)},'aba'))})/
  19     and print 'ok';
  20 CODE
  21
  22 fresh_perl_is(<<'CODE', 'ok', {}, 'match vars are localized');
  23 my $x = 'aba';
  24 $x =~ s/(a)(?{ 'moo' =~ m{(o)} })/uc($1)/e;
  25 print 'ok' if $x eq 'Aba';
  26 CODE
  27
  28 my $preamble = <<'CODE';
  29 sub build_obj {
  30   # In the real world we would die on validation fails, but RT#27838
  31   # is still unresolved, so don't tempt fate.
  32   $hash->{name} =~ /^[A-Z][a-z]+ [A-Z][a-z]+$/ or return "name error";
  33   $hash->{age} =~ /^[1-9][0-9]*$/ or return "age error";
  34
  35   # Add another layer of (?{...}) to try really hard to break things
  36   $hash->{square} =~
  37   /^(\d+)(?(?{my $sqrt = sprintf "%.0f", sqrt($^N); $sqrt**2==$^N })|(?!))$/
  38   or return "squareness error";
  39
  40   return bless { %$hash }, "Foo";
  41 }
  42
  43 sub match {
  44   my $str = shift;
  45   our ($hash, $obj);
  46   # Do something like Regexp::Grammars does building an object.
  47   my $matched = $str =~ /
  48     ()
  49     ([A-Za-z][A-Za-z ]*)(?{ local $hash->{name} = $^N }),[ ]
  50     (\d+)(?{ local $hash->{age} = $^N })[ ]years[ ]old,[ ]
  51     secret[ ]number[ ](\d+)(?{ local $hash->{square} = $^N }).
  52     (?{ $obj = build_obj(); })
  53   /x;
  54
  55   if ($matched) {
  56     print "match ";
  57     if (ref($obj)) {
  58       print ref($obj), ":$obj->{name}:$obj->{age}:$obj->{square}";
  59     } else {
  60       print $obj, ":$hash->{name}:$hash->{age}:$hash->{square}";
  61     }
  62   } else {
  63     print "no match $hash->{name}:$hash->{age}:$hash->{square}";
  64   }
  65
  66 }
  67 CODE
  68
  69 fresh_perl_is($preamble . <<'CODE', 'match Foo:John Smith:42:36', {}, 'regex distillation 1');
  70 match("John Smith, 42 years old, secret number 36.");
  71 CODE
  72
  73 fresh_perl_is($preamble . <<'CODE', 'match Foo:John Smith:42:36', {}, 'regex distillation 2');
  74 match("Jim Jones, 35 years old, secret wombat 007."
  75   ." John Smith, 42 years old, secret number 36.");
  76 CODE
  77
  78 fresh_perl_is($preamble . <<'CODE', 'match squareness error:::', {}, 'regex distillation 3');
  79 match("John Smith, 54 years old, secret number 7.");
  80 CODE
  81
  82 fresh_perl_is($preamble . <<'CODE', 'no match ::', {}, 'regex distillation 4');
  83 match("Jim Jones, 35 years old, secret wombat 007.");
  84 CODE
  85
  86 done_testing;