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 (106);
  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     "$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
  23 # test blessing simple types
  24
  25 $a1 = bless {}, "A";
  26 expected($a1, "A", "HASH");
  27 $b1 = bless [], "B";
  28 expected($b1, "B", "ARRAY");
  29 $c1 = bless \(map "$_", "test"), "C";
  30 expected($c1, "C", "SCALAR");
  31 our $test = "foo"; $d1 = bless \*test, "D";
  32 expected($d1, "D", "GLOB");
  33 $e1 = bless sub { 1 }, "E";
  34 expected($e1, "E", "CODE");
  35 $f1 = bless \[], "F";
  36 expected($f1, "F", "REF");
  37 $g1 = bless \substr("test", 1, 2), "G";
  38 expected($g1, "G", "LVALUE");
  39
  40 # blessing ref to object doesn't modify object
  41
  42 expected(bless(\$a1, "F"), "F", "REF");
  43 expected($a1, "A", "HASH");
  44
  45 # reblessing does modify object
  46
  47 bless $a1, "A2";
  48 expected($a1, "A2", "HASH");
  49
  50 # local and my
  51 {
  52     local $a1 = bless $a1, "A3";        # should rebless outer $a1
  53     local $b1 = bless [], "B3";
  54     my $c1 = bless $c1, "C3";           # should rebless outer $c1
  55     our $test2 = ""; my $d1 = bless \*test2, "D3";
  56     expected($a1, "A3", "HASH");
  57     expected($b1, "B3", "ARRAY");
  58     expected($c1, "C3", "SCALAR");
  59     expected($d1, "D3", "GLOB");
  60 }
  61 expected($a1, "A3", "HASH");
  62 expected($b1, "B", "ARRAY");
  63 expected($c1, "C3", "SCALAR");
  64 expected($d1, "D", "GLOB");
  65
  66 # class is magic
  67 "E" =~ /(.)/;
  68 expected(bless({}, $1), "E", "HASH");
  69 {
  70     local $! = 1;
  71     my $string = "$!";
  72     $! = 2;     # attempt to avoid cached string
  73     $! = 1;
  74     expected(bless({}, $!), $string, "HASH");
  75
  76 # ref is ref to magic
  77     {
  78         {
  79             package F;
  80             sub test { main::is(${$_[0]}, $string) }
  81         }
  82         $! = 2;
  83         $f1 = bless \$!, "F";
  84         $! = 1;
  85         $f1->test;
  86     }
  87 }
  88
  89 # ref is magic
  90 ### example of magic variable that is a reference??
  91
  92 # no class, or empty string (with a warning), or undef (with two)
  93 expected(bless([]), 'main', "ARRAY");
  94 {
  95     local $SIG{__WARN__} = sub { push @w, join '', @_ };
  96     use warnings;
  97
  98     $m = bless [];
  99     expected($m, 'main', "ARRAY");
 100     is (scalar @w, 0);
 101
 102     @w = ();
 103     $m = bless [], '';
 104     expected($m, 'main', "ARRAY");
 105     is (scalar @w, 1);
 106
 107     @w = ();
 108     $m = bless [], undef;
 109     expected($m, 'main', "ARRAY");
 110     is (scalar @w, 2);
 111 }
 112
 113 # class is a ref
 114 $a1 = bless {}, "A4";
 115 $b1 = eval { bless {}, $a1 };
 116 isnt ($@, '', "class is a ref");
 117
 118 # class is an overloaded ref
 119 {
 120     package H4;
 121     use overload '""' => sub { "C4" };
 122 }
 123 $h1 = bless {}, "H4";
 124 $c4 = eval { bless \$test, $h1 };
 125 is ($@, '', "class is an overloaded ref");
 126 expected($c4, 'C4', "SCALAR");