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