This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
mauve.t needs access to %Config, make sure it's available
[perl5.git] / lib / mauve.t
CommitLineData
792477b9
YO
1#!./perl
2
3use Test::More tests => 32 + 29 + 12 + 22;
4
5use mauve qw(refaddr reftype blessed weaken isweak);
6use vars qw($t $y $x *F $v $r $never_blessed);
7use Symbol qw(gensym);
8df6b97c 8use Config;
792477b9
YO
9
10# Ensure we do not trigger any tied methods
11tie *F, 'MyTie';
12
13my $i = 1;
14foreach $v (undef, 10, 'string') {
15 is(refaddr($v), !1, "not " . (defined($v) ? "'$v'" : "undef"));
16}
17
18foreach $r ({}, \$t, [], \*F, sub {}) {
19 my $n = "refaddr $r";
20 $n =~ /0x(\w+)/;
21 my $addr = do { local $^W; hex $1 };
22 my $before = ref($r);
23 is( refaddr($r), $addr, $n);
24 is( ref($r), $before, $n);
25
26 my $obj = bless $r, 'FooBar';
27 is( refaddr($r), $addr, "blessed with overload $n");
28 is( ref($r), 'FooBar', $n);
29}
30
31{
32 my $z = '77';
33 my $y = \$z;
34 my $a = '78';
35 my $b = \$a;
36 tie my %x, 'Hash3', {};
37 $x{$y} = 22;
38 $x{$b} = 23;
39 my $xy = $x{$y};
40 my $xb = $x{$b};
41 ok(ref($x{$y}));
42 ok(ref($x{$b}));
43 ok(refaddr($xy) == refaddr($y));
44 ok(refaddr($xb) == refaddr($b));
45 ok(refaddr($x{$y}));
46 ok(refaddr($x{$b}));
47}
48{
49 my $z = bless {}, '0';
50 ok(refaddr($z));
51 @{"0::ISA"} = qw(FooBar);
52 my $a = {};
53 my $r = refaddr($a);
54 $z = bless $a, '0';
55 ok(refaddr($z) > 10);
56 is(refaddr($z),$r,"foo");
57}
58{
59
60 my $RE = $] < 5.011 ? 'SCALAR' : 'REGEXP';
61 @test = (
62 [ !1, 1, 'number' ],
63 [ !1, 'A', 'string' ],
64 [ HASH => {}, 'HASH ref' ],
65 [ ARRAY => [], 'ARRAY ref' ],
66 [ SCALAR => \$t, 'SCALAR ref' ],
67 [ REF => \(\$t), 'REF ref' ],
68 [ GLOB => \*F, 'tied GLOB ref' ],
69 [ GLOB => gensym, 'GLOB ref' ],
70 [ CODE => sub {}, 'CODE ref' ],
71 [ IO => *STDIN{IO},'IO ref' ],
72 [ $RE => qr/x/, 'REGEEXP' ],
73 );
74
75 foreach $test (@test) {
76 my($type,$what, $n) = @$test;
77
78 is( reftype($what), $type, "reftype: $n");
79 next unless ref($what);
80
81 bless $what, "ABC";
82 is( reftype($what), $type, "reftype: $n");
83
84 bless $what, "0";
85 is( reftype($what), $type, "reftype: $n");
86 }
87}
88{
89 is(blessed(undef),"", 'undef is not blessed');
90 is(blessed(1),"", 'Numbers are not blessed');
91 is(blessed('A'),"", 'Strings are not blessed');
92 is(blessed({}),"", 'blessed: Unblessed HASH-ref');
93 is(blessed([]),"", 'blessed: Unblessed ARRAY-ref');
94 is(blessed(\$never_blessed),"", 'blessed: Unblessed SCALAR-ref');
95
96 $x = bless [], "ABC::\0::\t::\n::ABC";
97 is(blessed($x), "ABC::\0::\t::\n::ABC", 'blessed ARRAY-ref');
98
99 $x = bless [], "ABC";
100 is(blessed($x), "ABC", 'blessed ARRAY-ref');
101
102 $x = bless {}, "DEF";
103 is(blessed($x), "DEF", 'blessed HASH-ref');
104
105 $x = bless {}, "0";
106 cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref');
107
108 {
109 my $depth;
110 {
111 no warnings 'redefine';
112 *UNIVERSAL::can = sub { die "Burp!" if ++$depth > 2; blessed(shift) };
113 }
114 $x = bless {}, "DEF";
115 is(blessed($x), "DEF", 'recursion of UNIVERSAL::can');
116 }
117
118 {
119 my $obj = bless [], "Broken";
120 is( blessed($obj), "Broken", "blessed on broken isa() and can()" );
121 }
122}
123{
124 if (0) {
125 require Devel::Peek;
126 Devel::Peek->import('Dump');
127 }
128 else {
129 *Dump = sub {};
130 }
131
132
133 if(1) {
134
135 my ($y,$z);
136
137#
138# Case 1: two references, one is weakened, the other is then undef'ed.
139#
140
141 {
142 my $x = "foo";
143 $y = \$x;
144 $z = \$x;
145 }
146 print "# START\n";
147 Dump($y); Dump($z);
148
149 ok( ref($y) and ref($z));
150
151 print "# WEAK:\n";
152 weaken($y);
153 Dump($y); Dump($z);
154
155 ok( ref($y) and ref($z));
156
157 print "# UNDZ:\n";
158 undef($z);
159 Dump($y); Dump($z);
160
161 ok( not (defined($y) and defined($z)) );
162
163 print "# UNDY:\n";
164 undef($y);
165 Dump($y); Dump($z);
166
167 ok( not (defined($y) and defined($z)) );
168
169 print "# FIN:\n";
170 Dump($y); Dump($z);
171
172
173#
174# Case 2: one reference, which is weakened
175#
176
177 print "# CASE 2:\n";
178
179 {
180 my $x = "foo";
181 $y = \$x;
182 }
183
184 ok( ref($y) );
185 print "# BW: \n";
186 Dump($y);
187 weaken($y);
188 print "# AW: \n";
189 Dump($y);
190 ok( not defined $y );
191
192 print "# EXITBLOCK\n";
193 }
194
195#
196# Case 3: a circular structure
197#
198
199 my $flag = 0;
200 {
201 my $y = bless {}, 'Dest';
202 Dump($y);
203 print "# 1: $y\n";
204 $y->{Self} = $y;
205 Dump($y);
206 print "# 2: $y\n";
207 $y->{Flag} = \$flag;
208 print "# 3: $y\n";
209 weaken($y->{Self});
210 print "# WKED\n";
211 ok( ref($y) );
212 print "# VALS: HASH ",$y," SELF ",\$y->{Self}," Y ",\$y,
213 " FLAG: ",\$y->{Flag},"\n";
214 print "# VPRINT\n";
215 }
216 print "# OUT $flag\n";
217 ok( $flag == 1 );
218
219 print "# AFTER\n";
220
221 undef $flag;
222
223 print "# FLAGU\n";
224
225#
226# Case 4: a more complicated circular structure
227#
228
229 $flag = 0;
230 {
231 my $y = bless {}, 'Dest';
232 my $x = bless {}, 'Dest';
233 $x->{Ref} = $y;
234 $y->{Ref} = $x;
235 $x->{Flag} = \$flag;
236 $y->{Flag} = \$flag;
237 weaken($x->{Ref});
238 }
239 ok( $flag == 2 );
240
241#
242# Case 5: deleting a weakref before the other one
243#
244
245 my ($y,$z);
246 {
247 my $x = "foo";
248 $y = \$x;
249 $z = \$x;
250 }
251
252 print "# CASE5\n";
253 Dump($y);
254
255 weaken($y);
256 Dump($y);
257 undef($y);
258
259 ok( not defined $y);
260 ok( ref($z) );
261
262
263#
264# Case 6: test isweakref
265#
266
267 $a = 5;
268 ok(!isweak($a));
269 $b = \$a;
270 ok(!isweak($b));
271 weaken($b);
272 ok(isweak($b));
273 $b = \$a;
274 ok(!isweak($b));
275
276 my $x = {};
277 weaken($x->{Y} = \$a);
278 ok(isweak($x->{Y}));
279 ok(!isweak($x->{Z}));
280
281#
282# Case 7: test weaken on a read only ref
283#
284
285 SKIP: {
286 # Doesn't work for older perls, see bug [perl #24506]
287 skip("Test does not work with perl < 5.8.3", 5) if $] < 5.008003;
288
289 # in a MAD build, constants have refcnt 2, not 1
290 skip("Test does not work with MAD", 5) if exists $Config{mad};
291
292 $a = eval '\"hello"';
293 ok(ref($a)) or print "# didn't get a ref from eval\n";
294 $b = $a;
295 eval{weaken($b)};
296 # we didn't die
297 ok($@ eq "") or print "# died with $@\n";
298 ok(isweak($b));
299 ok($$b eq "hello") or print "# b is '$$b'\n";
300 $a="";
301 ok(not $b) or print "# b didn't go away\n";
302 }
303}
304
305package Broken;
306sub isa { die };
307sub can { die };
308
309package FooBar;
310
311use overload '0+' => sub { 10 },
312 '+' => sub { 10 + $_[1] },
313 '"' => sub { "10" };
314
315package MyTie;
316
317sub TIEHANDLE { bless {} }
318sub DESTROY {}
319
320sub AUTOLOAD {
321 warn "$AUTOLOAD called";
322 exit 1; # May be in an eval
323}
324
325package Hash3;
326
327use Scalar::Util qw(refaddr);
328
329sub TIEHASH
330{
331 my $pkg = shift;
332 return bless [ @_ ], $pkg;
333}
334sub FETCH
335{
336 my $self = shift;
337 my $key = shift;
338 my ($underlying) = @$self;
339 return $underlying->{refaddr($key)};
340}
341sub STORE
342{
343 my $self = shift;
344 my $key = shift;
345 my $value = shift;
346 my ($underlying) = @$self;
347 return ($underlying->{refaddr($key)} = $key);
348}
349
350
351
352package Dest;
353
354sub DESTROY {
355 print "# INCFLAG\n";
356 ${$_[0]{Flag}} ++;
357}