This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
install libgdbm and libdb in GitHub Actions
[perl5.git] / t / re / overload.t
CommitLineData
cb07477e 1#!./perl -w
a9f6cb1f
A
2
3BEGIN {
4 chdir 't' if -d 't';
cb07477e 5 require './test.pl';
624c42e2 6 set_up_inc(qw '../lib ../ext/re');
a9f6cb1f
A
7}
8
cb07477e
NC
9use strict;
10no 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 266done_testing();