1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6    set_up_inc('../lib');
7}
8
9plan (118);
10# Please do not eliminate the plan.  We have tests in DESTROY blocks.
11
12sub expected {
13    my($object, $package, $type) = @_;
14    print "# $object $package $type\n";
15    is(ref($object), $package);
16    my $r = qr/^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/;
17    like("$object", $r);
18    if ("$object" =~ $r) {
19	is($1, $type);
20	# in 64-bit platforms hex warns for 32+ -bit values
21	cmp_ok(do {no warnings 'portable'; hex($2)}, '==', $object);
22    }
23    else {
24	fail(); fail();
25    }
26}
27
28# test blessing simple types
29
30$a1 = bless {}, "A";
31expected($a1, "A", "HASH");
32$b1 = bless [], "B";
33expected($b1, "B", "ARRAY");
34$c1 = bless \(map "$_", "test"), "C";
35expected($c1, "C", "SCALAR");
36our $test = "foo"; $d1 = bless \*test, "D";
37expected($d1, "D", "GLOB");
38$e1 = bless sub { 1 }, "E";
39expected($e1, "E", "CODE");
40$f1 = bless \[], "F";
41expected($f1, "F", "REF");
42$g1 = bless \substr("test", 1, 2), "G";
43expected($g1, "G", "LVALUE");
44
45# blessing ref to object doesn't modify object
46
47expected(bless(\$a1, "F"), "F", "REF");
48expected($a1, "A", "HASH");
49
50# reblessing does modify object
51
52bless $a1, "A2";
53expected($a1, "A2", "HASH");
54
55# local and my
56{
57    local $a1 = bless $a1, "A3";	# should rebless outer $a1
58    local $b1 = bless [], "B3";
59    my $c1 = bless $c1, "C3";		# should rebless outer $c1
60    our $test2 = ""; my $d1 = bless \*test2, "D3";
61    expected($a1, "A3", "HASH");
62    expected($b1, "B3", "ARRAY");
63    expected($c1, "C3", "SCALAR");
64    expected($d1, "D3", "GLOB");
65}
66expected($a1, "A3", "HASH");
67expected($b1, "B", "ARRAY");
68expected($c1, "C3", "SCALAR");
69expected($d1, "D", "GLOB");
70
71# class is magic
72"E" =~ /(.)/;
73expected(bless({}, $1), "E", "HASH");
74{
75    local $! = 1;
76    my $string = "$!";
77    $! = 2;	# attempt to avoid cached string
78    $! = 1;
79    expected(bless({}, $!), $string, "HASH");
80
81# ref is ref to magic
82    {
83	{
84	    package F;
85	    sub test { main::is(${$_[0]}, $string) }
86	}
87	$! = 2;
88	$f1 = bless \$!, "F";
89	$! = 1;
90	$f1->test;
91    }
92}
93
94# ref is magic
95### example of magic variable that is a reference??
96
97# no class, or empty string (with a warning), or undef (with two)
98expected(bless([]), 'main', "ARRAY");
99{
100    local $SIG{__WARN__} = sub { push @w, join '', @_ };
101    use warnings;
102
103    $m = bless [];
104    expected($m, 'main', "ARRAY");
105    is (scalar @w, 0);
106
107    @w = ();
108    $m = bless [], '';
109    expected($m, 'main', "ARRAY");
110    is (scalar @w, 1);
111
112    @w = ();
113    $m = bless [], undef;
114    expected($m, 'main', "ARRAY");
115    is (scalar @w, 2);
116}
117
118# class is a ref
119$a1 = bless {}, "A4";
120$b1 = eval { bless {}, $a1 };
121like ($@, qr/^Attempt to bless into a reference at /, "class is a ref");
122
123# class is an overloaded ref
124{
125    package H4;
126    use overload '""' => sub { "C4" };
127}
128$h1 = bless {}, "H4";
129$c4 = eval { bless \$test, $h1 };
130is ($@, '', "class is an overloaded ref");
131expected($c4, 'C4', "SCALAR");
132
133{
134    my %h = 1..2;
135    my($k) = keys %h;
136    my $x=\$k;
137    bless $x, 'pam';
138    is(ref $x, 'pam');
139
140    my $a = bless \(keys %h), 'zap';
141    is(ref $a, 'zap');
142}
143
144bless [], "main::";
145ok(1, 'blessing into main:: does not crash'); # [perl #87388]
146
147sub _117941 { package _117941; bless [] }
148delete $::{"_117941::"};
149eval { _117941() };
150like $@, qr/^Attempt to bless into a freed package at /,
151        'bless with one arg when current stash is freed';
152
153for(__PACKAGE__) {
154    eval { bless \$_ };
155    like $@, qr/^Modification of a read-only value attempted/,
156         'read-only COWs cannot be blessed';
157}
158
159sub TIESCALAR { bless \(my $thing = pop), shift }
160sub FETCH { ${$_[0]} }
161tie $tied, main => $untied = [];
162eval { bless $tied };
163is ref $untied, "main", 'blessing through tied refs' or diag $@;
164
165bless \$victim, "Food";
166eval 'bless \$Food::bard, "Bard"';
167sub Bard::DESTROY {
168    isnt ref(\$victim), '__ANON__',
169        'reblessing does not leave an object in limbo temporarily';
170    bless \$victim
171}
172undef *Food::;
173{
174    my $w;
175    # This should catch ‘Attempt to free unreferenced scalar’.
176    local $SIG{__WARN__} = sub { $w .= shift };
177    bless \$victim;
178    is $w, undef,
179       'no warnings when reblessing inside DESTROY triggered by reblessing'
180}
181
182TODO: {
183    my $ref;
184    sub new {
185        my ($class, $code) = @_;
186        my $ret = ref($code);
187        bless $code => $class;
188        return $ret;
189    }
190    for my $i (1 .. 2) {
191        $ref = main -> new (sub {$i});
192    }
193    is $ref, 'CODE', 'RT #3305: Code ref should not be blessed yet';
194
195    local $TODO = 'RT #3305';
196
197    for my $i (1 .. 2) {
198        $ref = main -> new (sub {});
199    }
200    is $ref, 'CODE', 'RT #3305: Code ref should not be blessed yet';
201}
202
203my $t_3306_c = 0;
204my $t_3306_s = 0;
205
206{
207    sub FooClosure::new {
208        my ($class, $code) = @_;
209        bless $code => $class;
210    }
211    sub FooClosure::DESTROY {
212        $t_3306_c++;
213    }
214
215    sub FooSub::new {
216        my ($class, $code) = @_;
217        bless $code => $class;
218    }
219    sub FooSub::DESTROY {
220        $t_3306_s++;
221    }
222
223    my $i = '';
224    FooClosure -> new (sub {$i});
225    FooSub -> new (sub {});
226}
227
228is $t_3306_c, 1, 'RT #3306: DESTROY should be called on CODE ref (works on closures)';
229
230TODO: {
231    local $TODO = 'RT #3306';
232    is $t_3306_s, 1, 'RT #3306: DESTROY should be called on CODE ref';
233}
234
235undef *FooClosure::;
236undef *FooSub::;
237