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 7BEGIN { 8 chdir 't' if -d 't'; 9 require './test.pl'; 10} 11 12fresh_perl_is(<<'CODE', 'ok', {}); 13'42' =~ /4(?{ 'foo' =~ m{(foo)} })2/ 14 and print 'ok'; 15CODE 16 17fresh_perl_is(<<'CODE', 'ok', {}, 'RT#33936'); 18'aba' =~ /(??{join('',split(qr{(?=)},'aba'))})/ 19 and print 'ok'; 20CODE 21 22fresh_perl_is(<<'CODE', 'ok', {}, 'match vars are localized'); 23my $x = 'aba'; 24$x =~ s/(a)(?{ 'moo' =~ m{(o)} })/uc($1)/e; 25print 'ok' if $x eq 'Aba'; 26CODE 27 28my $preamble = <<'CODE'; 29sub 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 43sub 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} 67CODE 68 69fresh_perl_is($preamble . <<'CODE', 'match Foo:John Smith:42:36', {}, 'regex distillation 1'); 70match("John Smith, 42 years old, secret number 36."); 71CODE 72 73fresh_perl_is($preamble . <<'CODE', 'match Foo:John Smith:42:36', {}, 'regex distillation 2'); 74match("Jim Jones, 35 years old, secret wombat 007." 75 ." John Smith, 42 years old, secret number 36."); 76CODE 77 78fresh_perl_is($preamble . <<'CODE', 'match squareness error:::', {}, 'regex distillation 3'); 79match("John Smith, 54 years old, secret number 7."); 80CODE 81 82fresh_perl_is($preamble . <<'CODE', 'no match ::', {}, 'regex distillation 4'); 83match("Jim Jones, 35 years old, secret wombat 007."); 84CODE 85 86# RT #129199: this is mainly for ASAN etc's benefit 87fresh_perl_is(<<'CODE', '', {}, "RT #129199:"); 88/(?{<<""})/ 890 90CODE 91 92done_testing; 93