t/op/bless.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 plan (110);
  10
  11 sub expected {
  12     my($object, $package, $type) = @_;
  13     print "# $object $package $type\n";
  14     is(ref($object), $package);
  15     my $r = qr/^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/;
  16     like("$object", $r);
  17     if ("$object" =~ $r) {
  18         is($1, $type);
  19         # in 64-bit platforms hex warns for 32+ -bit values
  20         cmp_ok(do {no warnings 'portable'; hex($2)}, '==', $object);
  21     }
  22     else {
  23         fail(); fail();
  24     }
  25 }
  26
  27 # test blessing simple types
  28
  29 $a1 = bless {}, "A";
  30 expected($a1, "A", "HASH");
  31 $b1 = bless [], "B";
  32 expected($b1, "B", "ARRAY");
  33 $c1 = bless \(map "$_", "test"), "C";
  34 expected($c1, "C", "SCALAR");
  35 our $test = "foo"; $d1 = bless \*test, "D";
  36 expected($d1, "D", "GLOB");
  37 $e1 = bless sub { 1 }, "E";
  38 expected($e1, "E", "CODE");
  39 $f1 = bless \[], "F";
  40 expected($f1, "F", "REF");
  41 $g1 = bless \substr("test", 1, 2), "G";
  42 expected($g1, "G", "LVALUE");
  43
  44 # blessing ref to object doesn't modify object
  45
  46 expected(bless(\$a1, "F"), "F", "REF");
  47 expected($a1, "A", "HASH");
  48
  49 # reblessing does modify object
  50
  51 bless $a1, "A2";
  52 expected($a1, "A2", "HASH");
  53
  54 # local and my
  55 {
  56     local $a1 = bless $a1, "A3";        # should rebless outer $a1
  57     local $b1 = bless [], "B3";
  58     my $c1 = bless $c1, "C3";           # should rebless outer $c1
  59     our $test2 = ""; my $d1 = bless \*test2, "D3";
  60     expected($a1, "A3", "HASH");
  61     expected($b1, "B3", "ARRAY");
  62     expected($c1, "C3", "SCALAR");
  63     expected($d1, "D3", "GLOB");
  64 }
  65 expected($a1, "A3", "HASH");
  66 expected($b1, "B", "ARRAY");
  67 expected($c1, "C3", "SCALAR");
  68 expected($d1, "D", "GLOB");
  69
  70 # class is magic
  71 "E" =~ /(.)/;
  72 expected(bless({}, $1), "E", "HASH");
  73 {
  74     local $! = 1;
  75     my $string = "$!";
  76     $! = 2;     # attempt to avoid cached string
  77     $! = 1;
  78     expected(bless({}, $!), $string, "HASH");
  79
  80 # ref is ref to magic
  81     {
  82         {
  83             package F;
  84             sub test { main::is(${$_[0]}, $string) }
  85         }
  86         $! = 2;
  87         $f1 = bless \$!, "F";
  88         $! = 1;
  89         $f1->test;
  90     }
  91 }
  92
  93 # ref is magic
  94 ### example of magic variable that is a reference??
  95
  96 # no class, or empty string (with a warning), or undef (with two)
  97 expected(bless([]), 'main', "ARRAY");
  98 {
  99     local $SIG{__WARN__} = sub { push @w, join '', @_ };
 100     use warnings;
 101
 102     $m = bless [];
 103     expected($m, 'main', "ARRAY");
 104     is (scalar @w, 0);
 105
 106     @w = ();
 107     $m = bless [], '';
 108     expected($m, 'main', "ARRAY");
 109     is (scalar @w, 1);
 110
 111     @w = ();
 112     $m = bless [], undef;
 113     expected($m, 'main', "ARRAY");
 114     is (scalar @w, 2);
 115 }
 116
 117 # class is a ref
 118 $a1 = bless {}, "A4";
 119 $b1 = eval { bless {}, $a1 };
 120 isnt ($@, '', "class is a ref");
 121
 122 # class is an overloaded ref
 123 {
 124     package H4;
 125     use overload '""' => sub { "C4" };
 126 }
 127 $h1 = bless {}, "H4";
 128 $c4 = eval { bless \$test, $h1 };
 129 is ($@, '', "class is an overloaded ref");
 130 expected($c4, 'C4', "SCALAR");
 131
 132 {
 133     my %h = 1..2;
 134     my($k) = keys %h;
 135     my $x=\$k;
 136     bless $x, 'pam';
 137     is(ref $x, 'pam');
 138
 139     my $a = bless \(keys %h), 'zap';
 140     is(ref $a, 'zap');
 141 }
 142
 143 bless [], "main::";
 144 ok(1, 'blessing into main:: does not crash'); # [perl #87388]
 145
 146 sub _117941 { package _117941; bless [] }
 147 delete $::{"_117941::"};
 148 eval { _117941() };
 149 like $@, qr/^Attempt to bless into a freed package at /,
 150         'bless with one arg when current stash is freed';