1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    @INC = '../lib';
6    require './test.pl';
7}
8
9plan (106);
10
11sub 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";
26expected($a1, "A", "HASH");
27$b1 = bless [], "B";
28expected($b1, "B", "ARRAY");
29$c1 = bless \(map "$_", "test"), "C";
30expected($c1, "C", "SCALAR");
31our $test = "foo"; $d1 = bless \*test, "D";
32expected($d1, "D", "GLOB");
33$e1 = bless sub { 1 }, "E";
34expected($e1, "E", "CODE");
35$f1 = bless \[], "F";
36expected($f1, "F", "REF");
37$g1 = bless \substr("test", 1, 2), "G";
38expected($g1, "G", "LVALUE");
39
40# blessing ref to object doesn't modify object
41
42expected(bless(\$a1, "F"), "F", "REF");
43expected($a1, "A", "HASH");
44
45# reblessing does modify object
46
47bless $a1, "A2";
48expected($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}
61expected($a1, "A3", "HASH");
62expected($b1, "B", "ARRAY");
63expected($c1, "C3", "SCALAR");
64expected($d1, "D", "GLOB");
65
66# class is magic
67"E" =~ /(.)/;
68expected(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)
93expected(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 };
116isnt ($@, '', "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 };
125is ($@, '', "class is an overloaded ref");
126expected($c4, 'C4', "SCALAR");
127