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