t/re/overload.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use strict;
  10 no  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
 266 done_testing();