t/op/bless.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 plan (118);
  10 # Please do not eliminate the plan.  We have tests in DESTROY blocks.
  11
  12 sub expected {
  13     my($object, $package, $type) = @_;
  14     print "# $object $package $type\n";
  15     is(ref($object), $package);
  16     my $r = qr/^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/;
  17     like("$object", $r);
  18     if ("$object" =~ $r) {
  19         is($1, $type);
  20         # in 64-bit platforms hex warns for 32+ -bit values
  21         cmp_ok(do {no warnings 'portable'; hex($2)}, '==', $object);
  22     }
  23     else {
  24         fail(); fail();
  25     }
  26 }
  27
  28 # test blessing simple types
  29
  30 $a1 = bless {}, "A";
  31 expected($a1, "A", "HASH");
  32 $b1 = bless [], "B";
  33 expected($b1, "B", "ARRAY");
  34 $c1 = bless \(map "$_", "test"), "C";
  35 expected($c1, "C", "SCALAR");
  36 our $test = "foo"; $d1 = bless \*test, "D";
  37 expected($d1, "D", "GLOB");
  38 $e1 = bless sub { 1 }, "E";
  39 expected($e1, "E", "CODE");
  40 $f1 = bless \[], "F";
  41 expected($f1, "F", "REF");
  42 $g1 = bless \substr("test", 1, 2), "G";
  43 expected($g1, "G", "LVALUE");
  44
  45 # blessing ref to object doesn't modify object
  46
  47 expected(bless(\$a1, "F"), "F", "REF");
  48 expected($a1, "A", "HASH");
  49
  50 # reblessing does modify object
  51
  52 bless $a1, "A2";
  53 expected($a1, "A2", "HASH");
  54
  55 # local and my
  56 {
  57     local $a1 = bless $a1, "A3";        # should rebless outer $a1
  58     local $b1 = bless [], "B3";
  59     my $c1 = bless $c1, "C3";           # should rebless outer $c1
  60     our $test2 = ""; my $d1 = bless \*test2, "D3";
  61     expected($a1, "A3", "HASH");
  62     expected($b1, "B3", "ARRAY");
  63     expected($c1, "C3", "SCALAR");
  64     expected($d1, "D3", "GLOB");
  65 }
  66 expected($a1, "A3", "HASH");
  67 expected($b1, "B", "ARRAY");
  68 expected($c1, "C3", "SCALAR");
  69 expected($d1, "D", "GLOB");
  70
  71 # class is magic
  72 "E" =~ /(.)/;
  73 expected(bless({}, $1), "E", "HASH");
  74 {
  75     local $! = 1;
  76     my $string = "$!";
  77     $! = 2;     # attempt to avoid cached string
  78     $! = 1;
  79     expected(bless({}, $!), $string, "HASH");
  80
  81 # ref is ref to magic
  82     {
  83         {
  84             package F;
  85             sub test { main::is(${$_[0]}, $string) }
  86         }
  87         $! = 2;
  88         $f1 = bless \$!, "F";
  89         $! = 1;
  90         $f1->test;
  91     }
  92 }
  93
  94 # ref is magic
  95 ### example of magic variable that is a reference??
  96
  97 # no class, or empty string (with a warning), or undef (with two)
  98 expected(bless([]), 'main', "ARRAY");
  99 {
 100     local $SIG{__WARN__} = sub { push @w, join '', @_ };
 101     use warnings;
 102
 103     $m = bless [];
 104     expected($m, 'main', "ARRAY");
 105     is (scalar @w, 0);
 106
 107     @w = ();
 108     $m = bless [], '';
 109     expected($m, 'main', "ARRAY");
 110     is (scalar @w, 1);
 111
 112     @w = ();
 113     $m = bless [], undef;
 114     expected($m, 'main', "ARRAY");
 115     is (scalar @w, 2);
 116 }
 117
 118 # class is a ref
 119 $a1 = bless {}, "A4";
 120 $b1 = eval { bless {}, $a1 };
 121 like ($@, qr/^Attempt to bless into a reference at /, "class is a ref");
 122
 123 # class is an overloaded ref
 124 {
 125     package H4;
 126     use overload '""' => sub { "C4" };
 127 }
 128 $h1 = bless {}, "H4";
 129 $c4 = eval { bless \$test, $h1 };
 130 is ($@, '', "class is an overloaded ref");
 131 expected($c4, 'C4', "SCALAR");
 132
 133 {
 134     my %h = 1..2;
 135     my($k) = keys %h;
 136     my $x=\$k;
 137     bless $x, 'pam';
 138     is(ref $x, 'pam');
 139
 140     my $a = bless \(keys %h), 'zap';
 141     is(ref $a, 'zap');
 142 }
 143
 144 bless [], "main::";
 145 ok(1, 'blessing into main:: does not crash'); # [perl #87388]
 146
 147 sub _117941 { package _117941; bless [] }
 148 delete $::{"_117941::"};
 149 eval { _117941() };
 150 like $@, qr/^Attempt to bless into a freed package at /,
 151         'bless with one arg when current stash is freed';
 152
 153 for(__PACKAGE__) {
 154     eval { bless \$_ };
 155     like $@, qr/^Modification of a read-only value attempted/,
 156          'read-only COWs cannot be blessed';
 157 }
 158
 159 sub TIESCALAR { bless \(my $thing = pop), shift }
 160 sub FETCH { ${$_[0]} }
 161 tie $tied, main => $untied = [];
 162 eval { bless $tied };
 163 is ref $untied, "main", 'blessing through tied refs' or diag $@;
 164
 165 bless \$victim, "Food";
 166 eval 'bless \$Food::bard, "Bard"';
 167 sub Bard::DESTROY {
 168     isnt ref(\$victim), '__ANON__',
 169         'reblessing does not leave an object in limbo temporarily';
 170     bless \$victim
 171 }
 172 undef *Food::;
 173 {
 174     my $w;
 175     # This should catch ‘Attempt to free unreferenced scalar’.
 176     local $SIG{__WARN__} = sub { $w .= shift };
 177     bless \$victim;
 178     is $w, undef,
 179        'no warnings when reblessing inside DESTROY triggered by reblessing'
 180 }
 181
 182 TODO: {
 183     my $ref;
 184     sub new {
 185         my ($class, $code) = @_;
 186         my $ret = ref($code);
 187         bless $code => $class;
 188         return $ret;
 189     }
 190     for my $i (1 .. 2) {
 191         $ref = main -> new (sub {$i});
 192     }
 193     is $ref, 'CODE', 'RT #3305: Code ref should not be blessed yet';
 194
 195     local $TODO = 'RT #3305';
 196
 197     for my $i (1 .. 2) {
 198         $ref = main -> new (sub {});
 199     }
 200     is $ref, 'CODE', 'RT #3305: Code ref should not be blessed yet';
 201 }
 202
 203 my $t_3306_c = 0;
 204 my $t_3306_s = 0;
 205
 206 {
 207     sub FooClosure::new {
 208         my ($class, $code) = @_;
 209         bless $code => $class;
 210     }
 211     sub FooClosure::DESTROY {
 212         $t_3306_c++;
 213     }
 214
 215     sub FooSub::new {
 216         my ($class, $code) = @_;
 217         bless $code => $class;
 218     }
 219     sub FooSub::DESTROY {
 220         $t_3306_s++;
 221     }
 222
 223     my $i = '';
 224     FooClosure -> new (sub {$i});
 225     FooSub -> new (sub {});
 226 }
 227
 228 is $t_3306_c, 1, 'RT #3306: DESTROY should be called on CODE ref (works on closures)';
 229
 230 TODO: {
 231     local $TODO = 'RT #3306';
 232     is $t_3306_s, 1, 'RT #3306: DESTROY should be called on CODE ref';
 233 }
 234
 235 undef *FooClosure::;
 236 undef *FooSub::;