Commit | Line | Data |
---|---|---|
cb07477e | 1 | #!./perl -w |
a9f6cb1f A |
2 | |
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
cb07477e | 6 | require './test.pl'; |
a9f6cb1f A |
7 | } |
8 | ||
cb07477e NC |
9 | use strict; |
10 | no warnings 'syntax'; | |
a9f6cb1f A |
11 | |
12 | { | |
13 | # Bug #77084 points out a corruption problem when scalar //g is used | |
14 | # on overloaded objects. | |
15 | ||
f427b557 | 16 | my @realloc; |
a9f6cb1f A |
17 | my $TAG = "foo:bar"; |
18 | use overload '""' => sub {$TAG}; | |
19 | ||
20 | my $o = bless []; | |
21 | my ($one) = $o =~ /(.*)/g; | |
f427b557 | 22 | push @realloc, "xxxxxx"; # encourage realloc of SV and PVX |
a9f6cb1f A |
23 | is $one, $TAG, "list context //g against overloaded object"; |
24 | ||
a9f6cb1f A |
25 | |
26 | my $r = $o =~ /(.*)/g; | |
f427b557 | 27 | push @realloc, "yyyyyy"; # encourage realloc of SV and PVX |
a9f6cb1f | 28 | is $1, $TAG, "scalar context //g against overloaded object"; |
f3a0defb | 29 | pos ($o) = 0; # Reset pos, as //g in scalar context sets it to non-0. |
f427b557 | 30 | |
a9f6cb1f | 31 | $o =~ /(.*)/g; |
f427b557 | 32 | push @realloc, "zzzzzz"; # encourage realloc of SV and PVX |
a9f6cb1f A |
33 | is $1, $TAG, "void context //g against overloaded object"; |
34 | } | |
35 | ||
16cc92ae DM |
36 | { |
37 | # an overloaded stringify returning itself shouldn't loop indefinitely | |
38 | ||
39 | ||
40 | { | |
41 | package Self; | |
42 | use overload q{""} => sub { | |
43 | return shift; | |
44 | }, | |
45 | fallback => 1; | |
46 | } | |
47 | ||
48 | my $obj = bless [], 'Self'; | |
49 | my $r = qr/$obj/; | |
50 | pass("self object, 1 arg"); | |
51 | $r = qr/foo$obj/; | |
52 | pass("self object, 2 args"); | |
53 | } | |
54 | ||
55269f4f DM |
55 | { |
56 | # [perl #116823] | |
57 | # when overloading regex string constants, a different code path | |
58 | # was taken if the regex was compile-time, leading to overloaded | |
59 | # regex constant string segments not being handled correctly. | |
60 | # They were just treated as OP_CONST strings to be concatted together. | |
61 | # In particular, if the overload returned a regex object, it would | |
62 | # just be stringified rather than having any code blocks processed. | |
63 | ||
64 | BEGIN { | |
65 | overload::constant qr => sub { | |
66 | my ($raw, $cooked, $type) = @_; | |
67 | return $cooked unless defined $::CONST_QR_CLASS; | |
68 | if ($type =~ /qq?/) { | |
69 | return bless \$cooked, $::CONST_QR_CLASS; | |
70 | } else { | |
71 | return $cooked; | |
72 | } | |
73 | }; | |
74 | } | |
75 | ||
76 | { | |
77 | # returns a qr// object | |
78 | ||
79 | package OL_QR; | |
80 | use overload q{""} => sub { | |
81 | my $re = shift; | |
82 | return qr/(?{ $OL_QR::count++ })$$re/; | |
83 | }, | |
84 | fallback => 1; | |
85 | ||
86 | } | |
87 | ||
4f3e2518 DM |
88 | { |
89 | # returns a string | |
90 | ||
91 | package OL_STR; | |
92 | use overload q{""} => sub { | |
93 | my $re = shift; | |
94 | return qq/(?{ \$OL_STR::count++ })$$re/; | |
95 | }, | |
96 | fallback => 1; | |
97 | ||
98 | } | |
99 | ||
35738543 DM |
100 | { |
101 | # returns chr(str) | |
102 | ||
103 | package OL_CHR; | |
104 | use overload q{""} => sub { | |
105 | my $chr = shift; | |
106 | return chr($$chr); | |
107 | }, | |
108 | fallback => 1; | |
109 | ||
110 | } | |
111 | ||
4f3e2518 | 112 | |
55269f4f DM |
113 | my $qr; |
114 | ||
115 | $::CONST_QR_CLASS = 'OL_QR'; | |
116 | ||
117 | $OL_QR::count = 0; | |
118 | $qr = eval q{ qr/^foo$/; }; | |
119 | ok("foo" =~ $qr, "compile-time, OL_QR, single constant segment"); | |
120 | is($OL_QR::count, 1, "flag"); | |
121 | ||
122 | $OL_QR::count = 0; | |
123 | $qr = eval q{ qr/^foo$(?{ $OL_QR::count++ })/; }; | |
124 | ok("foo" =~ $qr, "compile-time, OL_QR, multiple constant segments"); | |
125 | is($OL_QR::count, 2, "qr2 flag"); | |
126 | ||
4f3e2518 DM |
127 | |
128 | # test /foo.../ when foo is given string overloading, | |
129 | # for various permutations of '...' | |
130 | ||
131 | $::CONST_QR_CLASS = 'OL_STR'; | |
132 | ||
133 | for my $has_re_eval (0, 1) { | |
134 | for my $has_qr (0, 1) { | |
135 | for my $has_code (0, 1) { | |
136 | for my $has_runtime (0, 1) { | |
137 | for my $has_runtime_code (0, 1) { | |
138 | if ($has_runtime_code) { | |
139 | next unless $has_runtime; | |
140 | } | |
141 | note( "re_eval=$has_re_eval " | |
142 | . "qr=$has_qr " | |
143 | . "code=$has_code " | |
144 | . "runtime=$has_runtime " | |
145 | . "runtime_code=$has_runtime_code"); | |
146 | my $eval = ''; | |
147 | $eval .= q{use re 'eval'; } if $has_re_eval; | |
148 | $eval .= q{$match = $str =~ }; | |
149 | $eval .= q{qr} if $has_qr; | |
150 | $eval .= q{/^abc}; | |
151 | $eval .= q{(?{$blocks++})} if $has_code; | |
152 | $eval .= q{$runtime} if $has_runtime; | |
153 | $eval .= q{/; 1;}; | |
154 | ||
155 | my $runtime = q{def}; | |
156 | $runtime .= q{(?{$run_blocks++})} if $has_runtime_code; | |
157 | ||
158 | my $blocks = 0; | |
159 | my $run_blocks = 0; | |
160 | my $match; | |
161 | my $str = "abc"; | |
162 | $str .= "def" if $runtime; | |
163 | ||
164 | my $result = eval $eval; | |
165 | my $err = $@; | |
166 | $result = $result ? 1 : 0; | |
167 | ||
168 | if (!$has_re_eval) { | |
169 | is($result, 0, "EVAL: $eval"); | |
170 | like($err, qr/Eval-group not allowed at runtime/, | |
171 | "\$\@: $eval"); | |
172 | next; | |
173 | } | |
174 | ||
175 | is($result, 1, "EVAL: $eval"); | |
176 | diag("\$@=[$err]") unless $result; | |
177 | ||
178 | is($match, 1, "MATCH: $eval"); | |
179 | is($blocks, $has_code, "blocks"); | |
180 | is($run_blocks, $has_runtime_code, "run_blocks"); | |
181 | ||
182 | } | |
183 | } | |
184 | } | |
185 | } | |
186 | } | |
187 | ||
35738543 DM |
188 | # if the pattern gets (undetectably in advance) upgraded to utf8 |
189 | # while being concatenated, it could mess up the alignment of the code | |
190 | # blocks, giving rise to 'Eval-group not allowed at runtime' errs. | |
191 | ||
192 | $::CONST_QR_CLASS = 'OL_CHR'; | |
193 | ||
194 | { | |
195 | my $count = 0; | |
196 | is(eval q{ "\x80\x{100}" =~ /128(?{ $count++ })256/ }, 1, | |
197 | "OL_CHR eval + match"); | |
198 | is($count, 1, "OL_CHR count"); | |
199 | } | |
4f3e2518 | 200 | |
55269f4f DM |
201 | undef $::CONST_QR_CLASS; |
202 | } | |
203 | ||
16cc92ae | 204 | |
491453ba DM |
205 | { |
206 | # [perl #115004] | |
207 | # array interpolation within patterns should handle qr overloading | |
208 | # (like it does for scalar vars) | |
209 | ||
210 | { | |
211 | package P115004; | |
212 | use overload 'qr' => sub { return qr/a/ }; | |
213 | } | |
214 | ||
215 | my $o = bless [], 'P115004'; | |
216 | my @a = ($o); | |
217 | ||
218 | ok("a" =~ /^$o$/, "qr overloading with scalar var interpolation"); | |
219 | ok("a" =~ /^@a$/, "qr overloading with array var interpolation"); | |
220 | ||
221 | } | |
222 | ||
c3923c33 DM |
223 | { |
224 | ||
225 | # if the pattern gets silently re-parsed, ensure that any eval'ed | |
226 | # code blocks get the correct lexical scope. The overloading of | |
227 | # concat, along with the modification of the text of the code block, | |
228 | # ensures that it has to be re-compiled. | |
229 | ||
230 | { | |
231 | package OL_MOD; | |
232 | use overload | |
233 | q{""} => sub { my ($pat) = @_; $pat->[0] }, | |
234 | q{.} => sub { | |
235 | my ($a1, $a2) = @_; | |
236 | $a1 = $a1->[0] if ref $a1; | |
237 | $a2 = $a2->[0] if ref $a2; | |
238 | my $s = "$a1$a2"; | |
239 | $s =~ s/x_var/y_var/; | |
240 | bless [ $s ]; | |
241 | }, | |
242 | ; | |
243 | } | |
244 | ||
245 | ||
246 | BEGIN { | |
247 | overload::constant qr => sub { bless [ $_[0] ], 'OL_MOD' }; | |
248 | } | |
249 | ||
250 | $::x_var = # duplicate to avoid 'only used once' warning | |
251 | $::x_var = "ABC"; | |
252 | my $x_var = "abc"; | |
253 | ||
254 | $::y_var = # duplicate to avoid 'only used once' warning | |
255 | $::y_var = "XYZ"; | |
256 | my $y_var = "xyz"; | |
257 | ||
258 | use re 'eval'; | |
259 | my $a = 'a'; | |
260 | ok("xyz" =~ m{^(??{ $x_var })$}, "OL_MOD"); | |
261 | ok("xyza" =~ m{^(??{ $x_var })$a$}, "OL_MOD runtime"); | |
262 | } | |
263 | ||
264 | ||
491453ba | 265 | |
cb07477e | 266 | done_testing(); |