dounwind(): do a POPBLOCK for final cx frame.

[perl5.git] / t / op / bless.t

diff --git a/t/op/bless.t b/t/op/bless.t
index 6aea7ba..69217fd 100644 (file)
--- a/t/op/bless.t
+++ b/t/op/bless.t
@@ -6,7 +6,8 @@ BEGIN {
     require './test.pl';
 }
 
-plan (106);
+plan (114);
+# Please do not eliminate the plan.  We have tests in DESTROY blocks.
 
 sub expected {
     my($object, $package, $type) = @_;
@@ -14,10 +15,14 @@ sub expected {
     is(ref($object), $package);
     my $r = qr/^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/;
     like("$object", $r);
-    "$object" =~ $r;
-    is($1, $type);
-    # in 64-bit platforms hex warns for 32+ -bit values
-    cmp_ok(do {no warnings 'portable'; hex($2)}, '==', $object);
+    if ("$object" =~ $r) {
+       is($1, $type);
+       # in 64-bit platforms hex warns for 32+ -bit values
+       cmp_ok(do {no warnings 'portable'; hex($2)}, '==', $object);
+    }
+    else {
+       fail(); fail();
+    }
 }
 
 # test blessing simple types
@@ -113,7 +118,7 @@ expected(bless([]), 'main', "ARRAY");
 # class is a ref
 $a1 = bless {}, "A4";
 $b1 = eval { bless {}, $a1 };
-isnt ($@, '', "class is a ref");
+like ($@, qr/^Attempt to bless into a reference at /, "class is a ref");
 
 # class is an overloaded ref
 {
@@ -124,3 +129,52 @@ $h1 = bless {}, "H4";
 $c4 = eval { bless \$test, $h1 };
 is ($@, '', "class is an overloaded ref");
 expected($c4, 'C4', "SCALAR");
+
+{
+    my %h = 1..2;
+    my($k) = keys %h; 
+    my $x=\$k;
+    bless $x, 'pam';
+    is(ref $x, 'pam');
+
+    my $a = bless \(keys %h), 'zap';
+    is(ref $a, 'zap');
+}
+
+bless [], "main::";
+ok(1, 'blessing into main:: does not crash'); # [perl #87388]
+
+sub _117941 { package _117941; bless [] }
+delete $::{"_117941::"};
+eval { _117941() };
+like $@, qr/^Attempt to bless into a freed package at /,
+        'bless with one arg when current stash is freed';
+
+for(__PACKAGE__) {
+    eval { bless \$_ };
+    like $@, qr/^Modification of a read-only value attempted/,
+         'read-only COWs cannot be blessed';
+}
+
+sub TIESCALAR { bless \(my $thing = pop), shift }
+sub FETCH { ${$_[0]} }
+tie $tied, main => $untied = [];
+eval { bless $tied };
+is ref $untied, "main", 'blessing through tied refs' or diag $@;
+
+bless \$victim, "Food";
+eval 'bless \$Food::bard, "Bard"';
+sub Bard::DESTROY {
+    isnt ref(\$victim), '__ANON__',
+        'reblessing does not leave an object in limbo temporarily';
+    bless \$victim
+}
+undef *Food::;
+{
+    my $w;
+    # This should catch ‘Attempt to free unreferenced scalar’.
+    local $SIG{__WARN__} = sub { $w .= shift };
+    bless \$victim;
+    is $w, undef,
+       'no warnings when reblessing inside DESTROY triggered by reblessing'
+}