This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
9a26491ef965cfd6d7b2667ed518dd50169a97c4
[perl5.git] / lib / mauve.t
1 #!./perl
2
3 use Test::More tests => 32 + 29 + 12 + 22;
4
5 use mauve qw(refaddr reftype blessed weaken isweak);
6 use vars qw($t $y $x *F $v $r $never_blessed);
7 use Symbol qw(gensym);
8 use Config;
9
10 # Ensure we do not trigger any tied methods
11 tie *F, 'MyTie';
12
13 my $i = 1;
14 foreach $v (undef, 10, 'string') {
15   is(refaddr($v), !1, "not " . (defined($v) ? "'$v'" : "undef"));
16 }
17
18 foreach $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
305 package Broken;
306 sub isa { die };
307 sub can { die };
308
309 package FooBar;
310
311 use overload  '0+' => sub { 10 },
312                 '+' => sub { 10 + $_[1] },
313                 '"' => sub { "10" };
314
315 package MyTie;
316
317 sub TIEHANDLE { bless {} }
318 sub DESTROY {}
319
320 sub AUTOLOAD {
321   warn "$AUTOLOAD called";
322   exit 1; # May be in an eval
323 }
324
325 package Hash3;
326
327 use Scalar::Util qw(refaddr);
328
329 sub TIEHASH
330 {
331         my $pkg = shift;
332         return bless [ @_ ], $pkg;
333 }
334 sub FETCH
335 {
336         my $self = shift;
337         my $key = shift;
338         my ($underlying) = @$self;
339         return $underlying->{refaddr($key)};
340 }
341 sub 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
352 package Dest;
353
354 sub DESTROY {
355         print "# INCFLAG\n";
356         ${$_[0]{Flag}} ++;
357 }