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