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