1#!./perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9use strict; 10no warnings 'syntax'; 11 12{ 13 # Bug #77084 points out a corruption problem when scalar //g is used 14 # on overloaded objects. 15 16 my @realloc; 17 my $TAG = "foo:bar"; 18 use overload '""' => sub {$TAG}; 19 20 my $o = bless []; 21 my ($one) = $o =~ /(.*)/g; 22 push @realloc, "xxxxxx"; # encourage realloc of SV and PVX 23 is $one, $TAG, "list context //g against overloaded object"; 24 25 26 my $r = $o =~ /(.*)/g; 27 push @realloc, "yyyyyy"; # encourage realloc of SV and PVX 28 is $1, $TAG, "scalar context //g against overloaded object"; 29 pos ($o) = 0; # Reset pos, as //g in scalar context sets it to non-0. 30 31 $o =~ /(.*)/g; 32 push @realloc, "zzzzzz"; # encourage realloc of SV and PVX 33 is $1, $TAG, "void context //g against overloaded object"; 34} 35 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 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 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 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 112 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 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 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 } 200 201 undef $::CONST_QR_CLASS; 202} 203 204 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 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 265 266done_testing(); 267