Commit | Line | Data |
---|---|---|
e69c50fe BF |
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"; | |
a15456de | 16 | is(ref($object), $package); |
e69c50fe BF |
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 [], "B"; | |
34 | expected($b1, "B", "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 [], "B3"; | |
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, "B3", "ARRAY"); | |
64 | expected($c1, "ᶜ3", "SCALAR"); | |
65 | expected($d1, "ɖ3", "GLOB"); | |
66 | } | |
67 | expected($a1, "ዐ3", "HASH"); | |
68 | expected($b1, "B", "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 | } |