t/op/bless.t

   1 #!./perl
   2
   3 print "1..29\n";
   4
   5 BEGIN {
   6     chdir 't' if -d 't';
   7     unshift @INC, '../lib' if -d '../lib';
   8 }
   9
  10 sub expected {
  11     my($object, $package, $type) = @_;
  12     return "" if (
  13         ref($object) eq $package
  14         && "$object" =~ /^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/
  15         && $1 eq $type
  16         && hex($2) == $object
  17     );
  18     print "# $object $package $type\n";
  19     return "not ";
  20 }
  21
  22 # test blessing simple types
  23
  24 $a1 = bless {}, "A";
  25 print expected($a1, "A", "HASH"), "ok 1\n";
  26 $b1 = bless [], "B";
  27 print expected($b1, "B", "ARRAY"), "ok 2\n";
  28 $c1 = bless \(map "$_", "test"), "C";
  29 print expected($c1, "C", "SCALAR"), "ok 3\n";
  30 $d1 = bless \*test, "D";
  31 print expected($d1, "D", "GLOB"), "ok 4\n";
  32 $e1 = bless sub { 1 }, "E";
  33 print expected($e1, "E", "CODE"), "ok 5\n";
  34 $f1 = bless \[], "F";
  35 print expected($f1, "F", "REF"), "ok 6\n";
  36 $g1 = bless \substr("test", 1, 2), "G";
  37 print expected($g1, "G", "LVALUE"), "ok 7\n";
  38
  39 # blessing ref to object doesn't modify object
  40
  41 print expected(bless(\$a1, "F"), "F", "REF"), "ok 8\n";
  42 print expected($a1, "A", "HASH"), "ok 9\n";
  43
  44 # reblessing does modify object
  45
  46 $a2 = bless $a1, "A2";
  47 print expected($a1, "A2", "HASH"), "ok 10\n";
  48
  49 # local and my
  50 {
  51     local $a1 = bless $a1, "A3";        # should rebless outer $a1
  52     local $b1 = bless [], "B3";
  53     my $c1 = bless $c1, "C3";           # should rebless outer $c1
  54     my $d1 = bless \*test2, "D3";
  55     print expected($a1, "A3", "HASH"), "ok 11\n";
  56     print expected($b1, "B3", "ARRAY"), "ok 12\n";
  57     print expected($c1, "C3", "SCALAR"), "ok 13\n";
  58     print expected($d1, "D3", "GLOB"), "ok 14\n";
  59 }
  60 print expected($a1, "A3", "HASH"), "ok 15\n";
  61 print expected($b1, "B", "ARRAY"), "ok 16\n";
  62 print expected($c1, "C3", "SCALAR"), "ok 17\n";
  63 print expected($d1, "D", "GLOB"), "ok 18\n";
  64
  65 # class is magic
  66 "E" =~ /(.)/;
  67 print expected(bless({}, $1), "E", "HASH"), "ok 19\n";
  68 {
  69     local $! = 1;
  70     my $string = "$!";
  71     $! = 2;     # attempt to avoid cached string
  72     $! = 1;
  73     print expected(bless({}, $!), $string, "HASH"), "ok 20\n";
  74
  75 # ref is ref to magic
  76     {
  77         {
  78             package F;
  79             sub test { ${$_[0]} eq $string or print "not " }
  80         }
  81         $! = 2;
  82         $f1 = bless \$!, "F";
  83         $! = 1;
  84         $f1->test;
  85         print "ok 21\n";
  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 print expected(bless([]), 'main', "ARRAY"), "ok 22\n";
  94 {
  95     local $SIG{__WARN__} = sub { push @w, join '', @_ };
  96     local $^W = 1;
  97
  98     $m = bless [];
  99     print expected($m, 'main', "ARRAY"), "ok 23\n";
 100     print @w ? "not ok 24\t# @w\n" : "ok 24\n";
 101
 102     @w = ();
 103     $m = bless [], '';
 104     print expected($m, 'main', "ARRAY"), "ok 25\n";
 105     print @w != 1 ? "not ok 26\t# @w\n" : "ok 26\n";
 106
 107     @w = ();
 108     $m = bless [], undef;
 109     print expected($m, 'main', "ARRAY"), "ok 27\n";
 110     print @w != 2 ? "not ok 28\t# @w\n" : "ok 28\n";
 111 }
 112
 113 # class is a ref
 114 $a1 = bless {}, "A4";
 115 $b1 = eval { bless {}, $a1 };
 116 print $@ ? "ok 29\n" : "not ok 29\t# $b1\n";