mktables: Omit unnecessary duplicates
[perl.git] / t / op / bless.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 plan (118);
10 # Please do not eliminate the plan.  We have tests in DESTROY blocks.
11
12 sub 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";
31 expected($a1, "A", "HASH");
32 $b1 = bless [], "B";
33 expected($b1, "B", "ARRAY");
34 $c1 = bless \(map "$_", "test"), "C";
35 expected($c1, "C", "SCALAR");
36 our $test = "foo"; $d1 = bless \*test, "D";
37 expected($d1, "D", "GLOB");
38 $e1 = bless sub { 1 }, "E";
39 expected($e1, "E", "CODE");
40 $f1 = bless \[], "F";
41 expected($f1, "F", "REF");
42 $g1 = bless \substr("test", 1, 2), "G";
43 expected($g1, "G", "LVALUE");
44
45 # blessing ref to object doesn't modify object
46
47 expected(bless(\$a1, "F"), "F", "REF");
48 expected($a1, "A", "HASH");
49
50 # reblessing does modify object
51
52 bless $a1, "A2";
53 expected($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 }
66 expected($a1, "A3", "HASH");
67 expected($b1, "B", "ARRAY");
68 expected($c1, "C3", "SCALAR");
69 expected($d1, "D", "GLOB");
70
71 # class is magic
72 "E" =~ /(.)/;
73 expected(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)
98 expected(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 };
121 like ($@, 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 };
130 is ($@, '', "class is an overloaded ref");
131 expected($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
144 bless [], "main::";
145 ok(1, 'blessing into main:: does not crash'); # [perl #87388]
146
147 sub _117941 { package _117941; bless [] }
148 delete $::{"_117941::"};
149 eval { _117941() };
150 like $@, qr/^Attempt to bless into a freed package at /,
151         'bless with one arg when current stash is freed';
152
153 for(__PACKAGE__) {
154     eval { bless \$_ };
155     like $@, qr/^Modification of a read-only value attempted/,
156          'read-only COWs cannot be blessed';
157 }
158
159 sub TIESCALAR { bless \(my $thing = pop), shift }
160 sub FETCH { ${$_[0]} }
161 tie $tied, main => $untied = [];
162 eval { bless $tied };
163 is ref $untied, "main", 'blessing through tied refs' or diag $@;
164
165 bless \$victim, "Food";
166 eval 'bless \$Food::bard, "Bard"';
167 sub Bard::DESTROY {
168     isnt ref(\$victim), '__ANON__',
169         'reblessing does not leave an object in limbo temporarily';
170     bless \$victim
171 }
172 undef *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
182 TODO: {
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
203 my $t_3306_c = 0;
204 my $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
228 is $t_3306_c, 1, 'RT #3306: DESTROY should be called on CODE ref (works on closures)';
229
230 TODO: {
231     local $TODO = 'RT #3306';
232     is $t_3306_s, 1, 'RT #3306: DESTROY should be called on CODE ref';
233 }
234
235 undef *FooClosure::;
236 undef *FooSub::;