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