| 1 | #!./perl -w |
| 2 | |
| 3 | use strict; |
| 4 | |
| 5 | BEGIN { |
| 6 | chdir 't' if -d 't'; |
| 7 | require './test.pl'; |
| 8 | } |
| 9 | |
| 10 | plan(tests => 32); |
| 11 | |
| 12 | sub r { |
| 13 | return qr/Good/; |
| 14 | } |
| 15 | |
| 16 | my $a = r(); |
| 17 | object_ok($a, 'Regexp'); |
| 18 | my $b = r(); |
| 19 | object_ok($b, 'Regexp'); |
| 20 | |
| 21 | my $b1 = $b; |
| 22 | |
| 23 | isnt($a + 0, $b + 0, 'Not the same object'); |
| 24 | |
| 25 | bless $b, 'Pie'; |
| 26 | |
| 27 | object_ok($b, 'Pie'); |
| 28 | object_ok($a, 'Regexp'); |
| 29 | object_ok($b1, 'Pie'); |
| 30 | |
| 31 | my $c = r(); |
| 32 | like("$c", qr/Good/); |
| 33 | my $d = r(); |
| 34 | like("$d", qr/Good/); |
| 35 | |
| 36 | my $d1 = $d; |
| 37 | |
| 38 | isnt($c + 0, $d + 0, 'Not the same object'); |
| 39 | |
| 40 | $$d = 'Bad'; |
| 41 | |
| 42 | like("$c", qr/Good/); |
| 43 | is($$d, 'Bad'); |
| 44 | is($$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 | |
| 49 | object_ok($d, 'Regexp'); |
| 50 | like("$d", qr/\ARegexp=SCALAR\(0x[0-9a-f]+\)\z/); |
| 51 | |
| 52 | # As does an explicitly blessed Regexp object. |
| 53 | |
| 54 | my $e = bless qr/Faux Pie/, 'Stew'; |
| 55 | |
| 56 | object_ok($e, 'Stew'); |
| 57 | $$e = 'Fake!'; |
| 58 | |
| 59 | is($$e, 'Fake!'); |
| 60 | object_ok($e, 'Stew'); |
| 61 | like("$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/; |
| 65 | like "bar",qr//,'[perl #96230] =~ qr// does not reuse last successful pat'; |
| 66 | "foo" =~ /foo/; |
| 67 | $_ = "bar"; |
| 68 | $_ =~ s/${qr||}/baz/; |
| 69 | is $_, "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 | |
| 76 | sub TIESCALAR{bless[]} |
| 77 | sub STORE { is ref\pop, "REGEXP", "stored regexp" } |
| 78 | tie my $t, ""; |
| 79 | $t = ${qr||}; |
| 80 | ok tied $t, 'tied var is still tied after regexp assignment'; |
| 81 | |
| 82 | bless \my $t2; |
| 83 | $t2 = ${qr||}; |
| 84 | is 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 | |
| 100 | sub { |
| 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}); |