t/uni/bless.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use utf8;
  10 use open qw( :utf8 :std );
  11 plan (84);
  12
  13 sub expected {
  14     my($object, $package, $type) = @_;
  15     print "# $object $package $type\n";
  16     is(ref($object), $package);
  17     my $r = qr/^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/u;
  18     like("$object", $r);
  19     if ("$object" =~ $r) {
  20         is($1, $type);
  21         # in 64-bit platforms hex warns for 32+ -bit values
  22         cmp_ok(do {no warnings 'portable'; hex($2)}, '==', $object);
  23     }
  24     else {
  25         fail(); fail();
  26     }
  27 }
  28
  29 # test blessing simple types
  30
  31 $a1 = bless {}, "ዐ";
  32 expected($a1, "ዐ", "HASH");
  33 $b1 = bless [], "Ｂ";
  34 expected($b1, "Ｂ", "ARRAY");
  35 $c1 = bless \(map "$_", "test"), "ᶜ";
  36 expected($c1, "ᶜ", "SCALAR");
  37 $tèst = "foo"; $d1 = bless \*tèst, "ɖ";
  38 expected($d1, "ɖ", "GLOB");
  39 $e1 = bless sub { 1 }, "ಎ";
  40 expected($e1, "ಎ", "CODE");
  41 $f1 = bless \[], "ḟ";
  42 expected($f1, "ḟ", "REF");
  43 $g1 = bless \substr("test", 1, 2), "ㄍ";
  44 expected($g1, "ㄍ", "LVALUE");
  45
  46 # blessing ref to object doesn't modify object
  47
  48 expected(bless(\$a1, "ḟ"), "ḟ", "REF");
  49 expected($a1, "ዐ", "HASH");
  50
  51 # reblessing does modify object
  52
  53 bless $a1, "ዐ2";
  54 expected($a1, "ዐ2", "HASH");
  55
  56 # local and my
  57 {
  58     local $a1 = bless $a1, "ዐ3";      # should rebless outer $a1
  59     local $b1 = bless [], "Ｂ3";
  60     my $c1 = bless $c1, "ᶜ3";         # should rebless outer $c1
  61     our $test2 = ""; my $d1 = bless \*test2, "ɖ3";
  62     expected($a1, "ዐ3", "HASH");
  63     expected($b1, "Ｂ3", "ARRAY");
  64     expected($c1, "ᶜ3", "SCALAR");
  65     expected($d1, "ɖ3", "GLOB");
  66 }
  67 expected($a1, "ዐ3", "HASH");
  68 expected($b1, "Ｂ", "ARRAY");
  69 expected($c1, "ᶜ3", "SCALAR");
  70 expected($d1, "ɖ", "GLOB");
  71
  72 # class is magic
  73 "ಎ" =~ /(.)/;
  74 expected(bless({}, $1), "ಎ", "HASH");
  75 {
  76     local $! = 1;
  77     my $string = "$!";
  78     $! = 2;     # attempt to avoid cached string
  79     $! = 1;
  80     expected(bless({}, $!), $string, "HASH");
  81
  82 # ref is ref to magic
  83     {
  84         {
  85             package ḟ;
  86             sub test { main::is(${$_[0]}, $string) }
  87         }
  88         $! = 2;
  89         $f1 = bless \$!, "ḟ";
  90         $! = 1;
  91         $f1->test;
  92     }
  93 }
  94
  95 # ref is magic
  96
  97 # class is a ref
  98 $a1 = bless {}, "ዐ4";
  99 $b1 = eval { bless {}, $a1 };
 100 isnt ($@, '', "class is a ref");
 101
 102 # class is an overloaded ref
 103 =begin
 104 $TODO = "Package not yet clean";
 105 {
 106     package ᚺ4;
 107     use overload '""' => sub { "ᶜ4" };
 108 }
 109 $h1 = bless {}, "ᚺ4";
 110 $c4 = eval { bless \$test, $h1 };
 111 is ($@, '', "class is an overloaded ref");
 112 expected($c4, 'ᶜ4', "SCALAR");
 113 =cut
 114
 115 {
 116     my %h = 1..2;
 117     my($k) = keys %h;
 118     my $x=\$k;
 119     bless $x, 'pàm';
 120     is(ref $x, 'pàm');
 121
 122     my $a = bless \(keys %h), 'zàp';
 123     is(ref $a, 'zàp');
 124 }