1#!./perl -w 2 3use strict; 4 5BEGIN { 6 chdir 't' if -d 't'; 7 require './test.pl'; 8} 9 10plan(tests => 37); 11 12sub r { 13 return qr/Good/; 14} 15 16my $a = r(); 17object_ok($a, 'Regexp'); 18my $b = r(); 19object_ok($b, 'Regexp'); 20 21my $b1 = $b; 22 23isnt($a + 0, $b + 0, 'Not the same object'); 24 25bless $b, 'Pie'; 26 27object_ok($b, 'Pie'); 28object_ok($a, 'Regexp'); 29object_ok($b1, 'Pie'); 30 31my $c = r(); 32like("$c", qr/Good/); 33my $d = r(); 34like("$d", qr/Good/); 35 36my $d1 = $d; 37 38isnt($c + 0, $d + 0, 'Not the same object'); 39 40$$d = 'Bad'; 41 42like("$c", qr/Good/); 43is($$d, 'Bad'); 44is($$d1, 'Bad'); 45 46# Assignment to an implicitly blessed Regexp object retains the class 47# (No different from direct value assignment to any other blessed SV 48 49object_ok($d, 'Regexp'); 50like("$d", qr/\ARegexp=SCALAR\(0x[0-9a-f]+\)\z/); 51 52# As does an explicitly blessed Regexp object. 53 54my $e = bless qr/Faux Pie/, 'Stew'; 55 56object_ok($e, 'Stew'); 57$$e = 'Fake!'; 58 59is($$e, 'Fake!'); 60object_ok($e, 'Stew'); 61like("$e", qr/\Stew=SCALAR\(0x[0-9a-f]+\)\z/); 62 63# [perl #96230] qr// should not have the reuse-last-pattern magic 64"foo" =~ /foo/; 65like "bar",qr//,'[perl #96230] =~ qr// does not reuse last successful pat'; 66"foo" =~ /foo/; 67$_ = "bar"; 68$_ =~ s/${qr||}/baz/; 69is $_, "bazbar", '[perl #96230] s/$qr// does not reuse last pat'; 70 71{ 72 my $x = 1.1; $x = ${qr//}; 73 pass 'no assertion failure when upgrading NV to regexp'; 74} 75 76sub TIESCALAR{bless[]} 77sub STORE { is ref\pop, "REGEXP", "stored regexp" } 78tie my $t, ""; 79$t = ${qr||}; 80ok tied $t, 'tied var is still tied after regexp assignment'; 81 82bless \my $t2; 83$t2 = ${qr||}; 84is ref \$t2, 'main', 'regexp assignment is not maledictory'; 85 86{ 87 my $w; 88 local $SIG{__WARN__}=sub{$w=$_[0]}; 89 $_ = 1.1; 90 $_ = ${qr//}; 91 is 0+$_, 0, 'double upgraded to regexp'; 92 like $w, qr/numeric/, 'produces non-numeric warning'; 93 undef $w; 94 $_ = 1; 95 $_ = ${qr//}; 96 is 0+$_, 0, 'int upgraded to regexp'; 97 like $w, qr/numeric/, 'likewise produces non-numeric warning'; 98} 99 100sub { 101 $_[0] = ${qr=crumpets=}; 102 is ref\$_[0], 'REGEXP', 'PVLVs'; 103 # Don't use like() here, as we would no longer be testing a PVLV. 104 ok " crumpets " =~ $_[0], 'using a regexpvlv as regexp'; 105 my $x = $_[0]; 106 is ref\$x, 'REGEXP', 'copying a regexpvlv'; 107 $_[0] = ${qr//}; 108 my $str = "".qr//; 109 $_[0] .= " "; 110 is $_[0], "$str ", 'stringifying regexpvlv in place'; 111} 112 ->((\my%hash)->{key}); 113 114# utf8::upgrade on an SVt_REGEXP should be a NOOP. 115# RT #131821 116 117{ 118 my $r1 = qr/X/i; 119 utf8::upgrade($$r1); 120 like "xxx", $r1, "RT #131821 utf8::upgrade: case insensitive"; 121} 122 123# after v5.27.2-30-gdf6b4bd, this was double-freeing the PVX buffer 124# and would crash under valgrind or similar. The eval ensures that the 125# regex any children are freed. 126 127{ 128 my %h; 129 eval q{ 130 sub { 131 my $r = qr/abc/; 132 $_[0] = $$r; 133 }->($h{foo}); 134 1; 135 }; 136} 137pass("PVLV-as-REGEXP double-free of PVX"); 138 139# a non-cow SVPV leaked it's string buffer when a REGEXP was assigned to 140# it. Give valgrind/ASan something to work on 141{ 142 my $s = substr("ab",0,1); # generate a non-COW string 143 my $r1 = qr/x/; 144 $s = $$r1; # make sure "a" isn't leaked 145 pass("REGEXP leak"); 146 147 my $dest = 0; 148 sub Foo99::DESTROY { $dest++ } 149 150 # ditto but make sure we don't leak a reference 151 { 152 my $ref = bless [], "Foo99"; 153 my $r2 = qr/x/; 154 $ref = $$r2; 155 } 156 is($dest, 1, "REGEXP RV leak"); 157 158 # and worse, assigning a REGEXP to an PVLV that had a string value 159 # caused an assert failure. Same code, but using $_[0] which is an 160 # lvalue, rather than $s. 161 162 my %h; 163 sub { 164 $_[0] = substr("ab",0,1); # generate a non-COW string 165 my $r = qr/x/; 166 $_[0] = $$r; # make sure "a" isn't leaked 167 }->($h{foo}); # passes PVLV to sub 168 is($h{foo}, "(?^:x)", "REGEXP PVLV leak"); 169} 170