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