Commit | Line | Data |
---|---|---|
23af30a1 DM |
1 | #!./perl |
2 | ||
3 | # Check that we don't recompile runtime patterns when the pattern hasn't | |
4 | # changed | |
5 | # | |
6 | # Works by checking the debugging output of 'use re debug' and, if | |
7 | # available, -Dr. We use both to check that the different code paths | |
e5bb0a1f | 8 | # with Perl_foo() versus the my_foo() under ext/re/ don't cause any |
23af30a1 DM |
9 | # changes. |
10 | ||
23af30a1 DM |
11 | $| = 1; |
12 | ||
23af30a1 DM |
13 | BEGIN { |
14 | chdir 't' if -d 't'; | |
15 | @INC = ('../lib','.'); | |
16 | require './test.pl'; | |
17 | skip_all_if_miniperl("no dynamic loading on miniperl, no re"); | |
18 | } | |
19 | ||
0b1b7115 JH |
20 | use strict; |
21 | use warnings; | |
23af30a1 | 22 | |
10beeb31 | 23 | plan tests => 48; |
23af30a1 DM |
24 | |
25 | my $results = runperl( | |
26 | switches => [ '-Dr' ], | |
27 | prog => '1', | |
28 | stderr => 1, | |
29 | ); | |
30 | my $has_Dr = $results !~ /Recompile perl with -DDEBUGGING/; | |
31 | ||
32 | my $tmpfile = tempfile(); | |
33 | ||
34 | ||
35 | # Check that a pattern triggers a regex compilation exactly N times, | |
36 | # using either -Dr or 'use re debug' | |
37 | # This is partially based on _fresh_perl() in test.pl | |
38 | ||
39 | sub _comp_n { | |
40 | my ($use_Dr, $n, $prog, $desc) = @_; | |
41 | open my $tf, ">$tmpfile" or die "Cannot open $tmpfile: $!"; | |
42 | ||
43 | my $switches = []; | |
44 | if ($use_Dr) { | |
45 | push @$switches, '-Dr'; | |
46 | } | |
47 | else { | |
48 | $prog = qq{use re qw(debug);\n$prog}; | |
49 | } | |
50 | ||
51 | print $tf $prog; | |
52 | close $tf or die "Cannot close $tmpfile: $!"; | |
53 | my $results = runperl( | |
54 | switches => $switches, | |
55 | progfile => $tmpfile, | |
56 | stderr => 1, | |
57 | ); | |
58 | ||
59 | my $status = $?; | |
60 | ||
61 | my $count = () = $results =~ /Final program:/g; | |
49bb71ae | 62 | if ($count == $n && !$status) { |
23af30a1 DM |
63 | pass($desc); |
64 | } | |
65 | else { | |
66 | fail($desc); | |
67 | _diag "# COUNT: $count EXPECTED $n\n"; | |
68 | _diag "# STATUS: $status\n"; | |
69 | _diag "# SWITCHES: @$switches\n"; | |
70 | _diag "# PROG: \n$prog\n"; | |
71 | # this is verbose; uncomment for debugging | |
72 | #_diag "# OUTPUT:\n------------------\n $results-------------------\n"; | |
73 | } | |
74 | } | |
75 | ||
76 | # Check that a pattern triggers a regex compilation exactly N times, | |
77 | ||
78 | sub comp_n { | |
79 | my ($n, $prog, $desc) = @_; | |
80 | if ($has_Dr) { | |
81 | _comp_n(1, $n, $prog, "$desc -Dr"); | |
82 | } | |
83 | else { | |
84 | SKIP: { | |
85 | skip("-Dr not compiled in"); | |
86 | } | |
87 | } | |
88 | _comp_n(0, @_); | |
89 | } | |
90 | ||
91 | # Check that a pattern triggers a regex compilation exactly once. | |
92 | ||
93 | sub comp_1 { | |
94 | comp_n(1, @_); | |
95 | } | |
96 | ||
97 | ||
98 | comp_1(<<'CODE', 'simple'); | |
99 | "a" =~ /$_/ for qw(a a a); | |
100 | CODE | |
101 | ||
102 | comp_1(<<'CODE', 'simple qr'); | |
103 | "a" =~ qr/$_/ for qw(a a a); | |
104 | CODE | |
105 | ||
106 | comp_1(<<'CODE', 'literal utf8'); | |
107 | "a" =~ /$_/ for "\x{100}", "\x{100}", "\x{100}"; | |
108 | CODE | |
109 | ||
110 | comp_1(<<'CODE', 'literal utf8 qr'); | |
111 | "a" =~ qr/$_/ for "\x{100}", "\x{100}", "\x{100}"; | |
112 | CODE | |
113 | ||
114 | comp_1(<<'CODE', 'longjmp literal utf8'); | |
115 | my $x = chr(0x80); | |
116 | "a" =~ /$x$_/ for "\x{100}", "\x{100}", "\x{100}"; | |
117 | CODE | |
118 | ||
119 | comp_1(<<'CODE', 'longjmp literal utf8 qr'); | |
120 | my $x = chr(0x80); | |
121 | "a" =~ qr/$x$_/ for "\x{100}", "\x{100}", "\x{100}"; | |
122 | CODE | |
123 | ||
124 | comp_1(<<'CODE', 'utf8'); | |
125 | "a" =~ /$_/ for '\x{100}', '\x{100}', '\x{100}'; | |
126 | CODE | |
127 | ||
128 | comp_1(<<'CODE', 'utf8 qr'); | |
129 | "a" =~ qr/$_/ for '\x{100}', '\x{100}', '\x{100}'; | |
130 | CODE | |
131 | ||
132 | comp_1(<<'CODE', 'longjmp utf8'); | |
133 | my $x = chr(0x80); | |
134 | "a" =~ /$x$_/ for '\x{100}', '\x{100}', '\x{100}'; | |
135 | CODE | |
136 | ||
137 | comp_1(<<'CODE', 'longjmp utf8'); | |
138 | my $x = chr(0x80); | |
139 | "a" =~ qr/$x$_/ for '\x{100}', '\x{100}', '\x{100}'; | |
140 | CODE | |
141 | ||
142 | comp_n(3, <<'CODE', 'mixed utf8'); | |
143 | "a" =~ /$_/ for "\x{c4}\x{80}", "\x{100}", "\x{c4}\x{80}"; | |
144 | CODE | |
145 | ||
146 | comp_n(3, <<'CODE', 'mixed utf8 qr'); | |
147 | "a" =~ qr/$_/ for "\x{c4}\x{80}", "\x{100}", "\x{c4}\x{80}"; | |
148 | CODE | |
149 | ||
d24ca0c5 DM |
150 | # note that that for runtime code, each pattern is compiled twice; the |
151 | # second time to allow the parser to see the code. | |
152 | ||
153 | comp_n(6, <<'CODE', 'runtime code'); | |
23af30a1 DM |
154 | my $x = '(?{1})'; |
155 | BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'" | |
156 | "a" =~ /a$_/ for $x, $x, $x; | |
157 | CODE | |
158 | ||
d24ca0c5 | 159 | comp_n(6, <<'CODE', 'runtime code qr'); |
23af30a1 DM |
160 | my $x = '(?{1})'; |
161 | BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'" | |
162 | "a" =~ qr/a$_/ for $x, $x, $x; | |
163 | CODE | |
164 | ||
165 | comp_n(4, <<'CODE', 'embedded code'); | |
166 | my $x = qr/(?{1})/; | |
167 | "a" =~ /a$_/ for $x, $x, $x; | |
168 | CODE | |
169 | ||
170 | comp_n(4, <<'CODE', 'embedded code qr'); | |
171 | my $x = qr/(?{1})/; | |
172 | "a" =~ qr/a$_/ for $x, $x, $x; | |
173 | CODE | |
174 | ||
d24ca0c5 | 175 | comp_n(7, <<'CODE', 'mixed code'); |
23af30a1 DM |
176 | my $x = qr/(?{1})/; |
177 | my $y = '(?{1})'; | |
178 | BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'" | |
179 | "a" =~ /a$x$_/ for $y, $y, $y; | |
180 | CODE | |
181 | ||
d24ca0c5 | 182 | comp_n(7, <<'CODE', 'mixed code qr'); |
23af30a1 DM |
183 | my $x = qr/(?{1})/; |
184 | my $y = '(?{1})'; | |
185 | BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'" | |
186 | "a" =~ qr/a$x$_/ for $y, $y, $y; | |
187 | CODE | |
dbc200c5 YO |
188 | |
189 | comp_n(6, <<'CODE', 'embedded code qr'); | |
190 | my $x = qr/a/i; | |
191 | my $y = qr/a/; | |
192 | "a" =~ qr/a$_/ for $x, $y, $x, $y; | |
193 | CODE | |
237da807 FC |
194 | |
195 | comp_n(2, <<'CODE', '(??{"constant"})'); | |
196 | "bb" =~ /(??{"abc"})/; | |
197 | CODE | |
198 | ||
199 | comp_n(2, <<'CODE', '(??{"folded"."constant"})'); | |
200 | "bb" =~ /(??{"ab"."c"})/; | |
201 | CODE | |
202 | ||
203 | comp_n(2, <<'CODE', '(??{$preused_scalar})'); | |
204 | $s = "abc"; | |
205 | "bb" =~ /(??{$s})/; | |
206 | CODE | |
207 | ||
208 | comp_n(2, <<'CODE', '(??{number})'); | |
209 | "bb" =~ /(??{123})/; | |
210 | CODE | |
10beeb31 FC |
211 | |
212 | comp_n(2, <<'CODE', '(??{$pvlv_regexp})'); | |
213 | sub { | |
214 | $_[0] = ${qr/abc/}; | |
215 | "bb" =~ /(??{$_[0]})/; | |
216 | }->($_[0]); | |
217 | CODE |