This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2266a74014da5af1038ff1041421e69a807eef6a
[perl5.git] / t / op / ref.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = qw(. ../lib);
6     require 'test.pl';
7 }
8
9 use strict qw(refs subs);
10
11 plan(221);
12
13 # Test glob operations.
14
15 $bar = "one";
16 $foo = "two";
17 {
18     local(*foo) = *bar;
19     is($foo, 'one');
20 }
21 is ($foo, 'two');
22
23 $baz = "three";
24 $foo = "four";
25 {
26     local(*foo) = 'baz';
27     is ($foo, 'three');
28 }
29 is ($foo, 'four');
30
31 $foo = "global";
32 {
33     local(*foo);
34     is ($foo, undef);
35     $foo = "local";
36     is ($foo, 'local');
37 }
38 is ($foo, 'global');
39
40 {
41     no strict 'refs';
42 # Test fake references.
43
44     $baz = "valid";
45     $bar = 'baz';
46     $foo = 'bar';
47     is ($$$foo, 'valid');
48 }
49
50 # Test real references.
51
52 $FOO = \$BAR;
53 $BAR = \$BAZ;
54 $BAZ = "hit";
55 is ($$$FOO, 'hit');
56
57 # Test references to real arrays.
58
59 my $test = curr_test();
60 @ary = ($test,$test+1,$test+2,$test+3);
61 $ref[0] = \@a;
62 $ref[1] = \@b;
63 $ref[2] = \@c;
64 $ref[3] = \@d;
65 for $i (3,1,2,0) {
66     push(@{$ref[$i]}, "ok $ary[$i]\n");
67 }
68 print @a;
69 print ${$ref[1]}[0];
70 print @{$ref[2]}[0];
71 {
72     no strict 'refs';
73     print @{'d'};
74 }
75 curr_test($test+4);
76
77 # Test references to references.
78
79 $refref = \\$x;
80 $x = "Good";
81 is ($$$refref, 'Good');
82
83 # Test nested anonymous lists.
84
85 $ref = [[],2,[3,4,5,]];
86 is (scalar @$ref, 3);
87 is ($$ref[1], 2);
88 is (${$$ref[2]}[2], 5);
89 is (scalar @{$$ref[0]}, 0);
90
91 is ($ref->[1], 2);
92 is ($ref->[2]->[0], 3);
93
94 # Test references to hashes of references.
95
96 $refref = \%whatever;
97 $refref->{"key"} = $ref;
98 is ($refref->{"key"}->[2]->[0], 3);
99
100 # Test to see if anonymous subarrays spring into existence.
101
102 $spring[5]->[0] = 123;
103 $spring[5]->[1] = 456;
104 push(@{$spring[5]}, 789);
105 is (join(':',@{$spring[5]}), "123:456:789");
106
107 # Test to see if anonymous subhashes spring into existence.
108
109 @{$spring2{"foo"}} = (1,2,3);
110 $spring2{"foo"}->[3] = 4;
111 is (join(':',@{$spring2{"foo"}}), "1:2:3:4");
112
113 # Test references to subroutines.
114
115 {
116     my $called;
117     sub mysub { $called++; }
118     $subref = \&mysub;
119     &$subref;
120     is ($called, 1);
121 }
122
123 # Test references to return values of operators (TARGs/PADTMPs)
124 {
125     my @refs;
126     for("a", "b") {
127         push @refs, \"$_"
128     }
129     is join(" ", map $$_, @refs), "a b", 'refgen+PADTMP';
130 }
131
132 $subrefref = \\&mysub2;
133 is ($$subrefref->("GOOD"), "good");
134 sub mysub2 { lc shift }
135
136 # Test REGEXP assignment
137
138 SKIP: {
139     skip_if_miniperl("no dynamic loading on miniperl, so can't load re", 5);
140     require re;
141     my $x = qr/x/;
142     my $str = "$x"; # regex stringification may change
143
144     my $y = $$x;
145     is ($y, $str, "bare REGEXP stringifies correctly");
146     ok (eval { "x" =~ $y }, "bare REGEXP matches correctly");
147     
148     my $z = \$y;
149     ok (re::is_regexp($z), "new ref to REXEXP passes is_regexp");
150     is ($z, $str, "new ref to REGEXP stringifies correctly");
151     ok (eval { "x" =~ $z }, "new ref to REGEXP matches correctly");
152 }
153 {
154     my ($x, $str);
155     {
156         my $y = qr/x/;
157         $str = "$y";
158         $x = $$y;
159     }
160     is ($x, $str, "REGEXP keeps a ref to its mother_re");
161     ok (eval { "x" =~ $x }, "REGEXP with mother_re still matches");
162 }
163
164 # Test the ref operator.
165
166 sub PVBM () { 'foo' }
167 { my $dummy = index 'foo', PVBM }
168
169 my $pviv = 1; "$pviv";
170 my $pvnv = 1.0; "$pvnv";
171 my $x;
172
173 # we don't test
174 #   tied lvalue => SCALAR, as we haven't tested tie yet
175 #   BIND, 'cos we can't create them yet
176 #   REGEXP, 'cos that requires overload or Scalar::Util
177 #   LVALUE ref, 'cos I can't work out how to create one :)
178
179 for (
180     [ 'undef',          SCALAR  => \undef               ],
181     [ 'constant IV',    SCALAR  => \1                   ],
182     [ 'constant NV',    SCALAR  => \1.0                 ],
183     [ 'constant PV',    SCALAR  => \'f'                 ],
184     [ 'scalar',         SCALAR  => \$x                  ],
185     [ 'PVIV',           SCALAR  => \$pviv               ],
186     [ 'PVNV',           SCALAR  => \$pvnv               ],
187     [ 'PVMG',           SCALAR  => \$0                  ],
188     [ 'PVBM',           SCALAR  => \PVBM                ],
189     [ 'vstring',        VSTRING => \v1                  ],
190     [ 'ref',            REF     => \\1                  ],
191     [ 'substr lvalue',  LVALUE  => \substr($x, 0, 0)    ],
192     [ 'pos lvalue',     LVALUE  => \pos                 ],
193     [ 'vec lvalue',     LVALUE  => \vec($x,0,1)         ],     
194     [ 'named array',    ARRAY   => \@ary                ],
195     [ 'anon array',     ARRAY   => [ 1 ]                ],
196     [ 'named hash',     HASH    => \%whatever           ],
197     [ 'anon hash',      HASH    => { a => 1 }           ],
198     [ 'named sub',      CODE    => \&mysub,             ],
199     [ 'anon sub',       CODE    => sub { 1; }           ],
200     [ 'glob',           GLOB    => \*foo                ],
201     [ 'format',         FORMAT  => *STDERR{FORMAT}      ],
202 ) {
203     my ($desc, $type, $ref) = @$_;
204     is (ref $ref, $type, "ref() for ref to $desc");
205     like ("$ref", qr/^$type\(0x[0-9a-f]+\)$/, "stringify for ref to $desc");
206 }
207
208 is (ref *STDOUT{IO}, 'IO::File', 'IO refs are blessed into IO::File');
209 like (*STDOUT{IO}, qr/^IO::File=IO\(0x[0-9a-f]+\)$/,
210     'stringify for IO refs');
211
212 # Test anonymous hash syntax.
213
214 $anonhash = {};
215 is (ref $anonhash, 'HASH');
216 $anonhash2 = {FOO => 'BAR', ABC => 'XYZ',};
217 is (join('', sort values %$anonhash2), 'BARXYZ');
218
219 # Test bless operator.
220
221 package MYHASH;
222
223 $object = bless $main'anonhash2;
224 main::is (ref $object, 'MYHASH');
225 main::is ($object->{ABC}, 'XYZ');
226
227 $object2 = bless {};
228 main::is (ref $object2, 'MYHASH');
229
230 # Test ordinary call on object method.
231
232 &mymethod($object,"argument");
233
234 sub mymethod {
235     local($THIS, @ARGS) = @_;
236     die 'Got a "' . ref($THIS). '" instead of a MYHASH'
237         unless ref $THIS eq 'MYHASH';
238     main::is ($ARGS[0], "argument");
239     main::is ($THIS->{FOO}, 'BAR');
240 }
241
242 # Test automatic destructor call.
243
244 $string = "bad";
245 $object = "foo";
246 $string = "good";
247 $main'anonhash2 = "foo";
248 $string = "";
249
250 DESTROY {
251     return unless $string;
252     main::is ($string, 'good');
253
254     # Test that the object has not already been "cursed".
255     main::isnt (ref shift, 'HASH');
256 }
257
258 # Now test inheritance of methods.
259
260 package OBJ;
261
262 @ISA = ('BASEOBJ');
263
264 $main'object = bless {FOO => 'foo', BAR => 'bar'};
265
266 package main;
267
268 # Test arrow-style method invocation.
269
270 is ($object->doit("BAR"), 'bar');
271
272 # Test indirect-object-style method invocation.
273
274 $foo = doit $object "FOO";
275 main::is ($foo, 'foo');
276
277 sub BASEOBJ'doit {
278     local $ref = shift;
279     die "Not an OBJ" unless ref $ref eq 'OBJ';
280     $ref->{shift()};
281 }
282
283 package UNIVERSAL;
284 @ISA = 'LASTCHANCE';
285
286 package LASTCHANCE;
287 sub foo { main::is ($_[1], 'works') }
288
289 package WHATEVER;
290 foo WHATEVER "works";
291
292 #
293 # test the \(@foo) construct
294 #
295 package main;
296 @foo = \(1..3);
297 @bar = \(@foo);
298 @baz = \(1,@foo,@bar);
299 is (scalar (@bar), 3);
300 is (scalar grep(ref($_), @bar), 3);
301 is (scalar (@baz), 3);
302
303 my(@fuu) = \(1..2,3);
304 my(@baa) = \(@fuu);
305 my(@bzz) = \(1,@fuu,@baa);
306 is (scalar (@baa), 3);
307 is (scalar grep(ref($_), @baa), 3);
308 is (scalar (@bzz), 3);
309
310 # also, it can't be an lvalue
311 eval '\\($x, $y) = (1, 2);';
312 like ($@, qr/Can\'t modify.*ref.*in.*assignment/);
313
314 # test for proper destruction of lexical objects
315 $test = curr_test();
316 sub larry::DESTROY { print "# larry\nok $test\n"; }
317 sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; }
318 sub moe::DESTROY   { print "# moe\nok ", $test + 2, "\n"; }
319
320 {
321     my ($joe, @curly, %larry);
322     my $moe = bless \$joe, 'moe';
323     my $curly = bless \@curly, 'curly';
324     my $larry = bless \%larry, 'larry';
325     print "# leaving block\n";
326 }
327
328 print "# left block\n";
329 curr_test($test + 3);
330
331 # another glob test
332
333
334 $foo = "garbage";
335 { local(*bar) = "foo" }
336 $bar = "glob 3";
337 local(*bar) = *bar;
338 is ($bar, "glob 3");
339
340 $var = "glob 4";
341 $_   = \$var;
342 is ($$_, 'glob 4');
343
344
345 # test if reblessing during destruction results in more destruction
346 $test = curr_test();
347 {
348     package A;
349     sub new { bless {}, shift }
350     DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" }
351     package _B;
352     sub new { bless {}, shift }
353     DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' }
354     package main;
355     my $b = _B->new;
356 }
357 curr_test($test + 2);
358
359 # test if $_[0] is properly protected in DESTROY()
360
361 {
362     my $test = curr_test();
363     my $i = 0;
364     local $SIG{'__DIE__'} = sub {
365         my $m = shift;
366         if ($i++ > 4) {
367             print "# infinite recursion, bailing\nnot ok $test\n";
368             exit 1;
369         }
370         like ($m, qr/^Modification of a read-only/);
371     };
372     package C;
373     sub new { bless {}, shift }
374     DESTROY { $_[0] = 'foo' }
375     {
376         print "# should generate an error...\n";
377         my $c = C->new;
378     }
379     print "# good, didn't recurse\n";
380 }
381
382 # test that DESTROY is called on all objects during global destruction,
383 # even those without hard references [perl #36347]
384
385 is(
386   runperl(
387    stderr => 1, prog => 'sub DESTROY { print qq-aaa\n- } bless \$a[0]'
388   ),
389  "aaa\n", 'DESTROY called on array elem'
390 );
391 is(
392   runperl(
393    stderr => 1,
394    prog => '{ bless \my@x; *a=sub{@x}}sub DESTROY { print qq-aaa\n- }'
395   ),
396  "aaa\n",
397  'DESTROY called on closure variable'
398 );
399
400
401 # test if refgen behaves with autoviv magic
402 {
403     my @a;
404     $a[1] = "good";
405     my $got;
406     for (@a) {
407         $got .= ${\$_};
408         $got .= ';';
409     }
410     is ($got, ";good;");
411 }
412
413 # This test is the reason for postponed destruction in sv_unref
414 $a = [1,2,3];
415 $a = $a->[1];
416 is ($a, 2);
417
418 # This test used to coredump. The BEGIN block is important as it causes the
419 # op that created the constant reference to be freed. Hence the only
420 # reference to the constant string "pass" is in $a. The hack that made
421 # sure $a = $a->[1] would work didn't work with references to constants.
422
423
424 foreach my $lexical ('', 'my $a; ') {
425   my $expect = "pass\n";
426   my $result = runperl (switches => ['-wl'], stderr => 1,
427     prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a');
428
429   is ($?, 0);
430   is ($result, $expect);
431 }
432
433 $test = curr_test();
434 sub x::DESTROY {print "ok ", $test + shift->[0], "\n"}
435 { my $a1 = bless [3],"x";
436   my $a2 = bless [2],"x";
437   { my $a3 = bless [1],"x";
438     my $a4 = bless [0],"x";
439     567;
440   }
441 }
442 curr_test($test+4);
443
444 is (runperl (switches=>['-l'],
445              prog=> 'print 1; print qq-*$\*-;print 1;'),
446     "1\n*\n*\n1\n");
447
448 # bug #21347
449
450 runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' );
451 is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//');
452
453 runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1);
454 is ($?, 0, 'warn called inside UNIVERSAL::DESTROY');
455
456
457 # bug #22719
458
459 runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();');
460 is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)');
461
462 # bug #27268: freeing self-referential typeglobs could trigger
463 # "Attempt to free unreferenced scalar" warnings
464
465 is (runperl(
466     prog => 'use Symbol;my $x=bless \gensym,q{t}; print;*$$x=$x',
467     stderr => 1
468 ), '', 'freeing self-referential typeglob');
469
470 # using a regex in the destructor for STDOUT segfaulted because the
471 # REGEX pad had already been freed (ithreads build only). The
472 # object is required to trigger the early freeing of GV refs to to STDOUT
473
474 TODO: {
475     local $TODO = "works but output through pipe is mangled" if $^O eq 'VMS';
476     like (runperl(
477         prog => '$x=bless[]; sub IO::Handle::DESTROY{$_=q{bad};s/bad/ok/;print}',
478         stderr => 1
479           ), qr/^(ok)+$/, 'STDOUT destructor');
480 }
481
482 TODO: {
483     no strict 'refs';
484     $name8 = chr 163;
485     $name_utf8 = $name8 . chr 256;
486     chop $name_utf8;
487
488     is ($$name8, undef, 'Nothing before we start');
489     is ($$name_utf8, undef, 'Nothing before we start');
490     $$name8 = "Pound";
491     is ($$name8, "Pound", 'Accessing via 8 bit symref works');
492     local $TODO = "UTF8 mangled in symrefs";
493     is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works');
494 }
495
496 TODO: {
497     no strict 'refs';
498     $name_utf8 = $name = chr 9787;
499     utf8::encode $name_utf8;
500
501     is (length $name, 1, "Name is 1 char");
502     is (length $name_utf8, 3, "UTF8 representation is 3 chars");
503
504     is ($$name, undef, 'Nothing before we start');
505     is ($$name_utf8, undef, 'Nothing before we start');
506     $$name = "Face";
507     is ($$name, "Face", 'Accessing via Unicode symref works');
508     local $TODO = "UTF8 mangled in symrefs";
509     is ($$name_utf8, undef,
510         'Accessing via the UTF8 byte sequence gives nothing');
511 }
512
513 {
514     no strict 'refs';
515     $name1 = "\0Chalk";
516     $name2 = "\0Cheese";
517
518     isnt ($name1, $name2, "They differ");
519
520     is ($$name1, undef, 'Nothing before we start (scalars)');
521     is ($$name2, undef, 'Nothing before we start');
522     $$name1 = "Yummy";
523     is ($$name1, "Yummy", 'Accessing via the correct name works');
524     is ($$name2, undef,
525         'Accessing via a different NUL-containing name gives nothing');
526     # defined uses a different code path
527     ok (defined $$name1, 'defined via the correct name works');
528     ok (!defined $$name2,
529         'defined via a different NUL-containing name gives nothing');
530
531     is ($name1->[0], undef, 'Nothing before we start (arrays)');
532     is ($name2->[0], undef, 'Nothing before we start');
533     $name1->[0] = "Yummy";
534     is ($name1->[0], "Yummy", 'Accessing via the correct name works');
535     is ($name2->[0], undef,
536         'Accessing via a different NUL-containing name gives nothing');
537     ok (defined $name1->[0], 'defined via the correct name works');
538     ok (!defined$name2->[0],
539         'defined via a different NUL-containing name gives nothing');
540
541     my (undef, $one) = @{$name1}[2,3];
542     my (undef, $two) = @{$name2}[2,3];
543     is ($one, undef, 'Nothing before we start (array slices)');
544     is ($two, undef, 'Nothing before we start');
545     @{$name1}[2,3] = ("Very", "Yummy");
546     (undef, $one) = @{$name1}[2,3];
547     (undef, $two) = @{$name2}[2,3];
548     is ($one, "Yummy", 'Accessing via the correct name works');
549     is ($two, undef,
550         'Accessing via a different NUL-containing name gives nothing');
551     ok (defined $one, 'defined via the correct name works');
552     ok (!defined $two,
553         'defined via a different NUL-containing name gives nothing');
554
555     is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)');
556     is ($name2->{PWOF}, undef, 'Nothing before we start');
557     $name1->{PWOF} = "Yummy";
558     is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works');
559     is ($name2->{PWOF}, undef,
560         'Accessing via a different NUL-containing name gives nothing');
561     ok (defined $name1->{PWOF}, 'defined via the correct name works');
562     ok (!defined $name2->{PWOF},
563         'defined via a different NUL-containing name gives nothing');
564
565     my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'};
566     my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'};
567     is ($one, undef, 'Nothing before we start (hash slices)');
568     is ($two, undef, 'Nothing before we start');
569     @{$name1}{'SNIF', 'BEEYOOP'} = ("Very", "Yummy");
570     (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'};
571     (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'};
572     is ($one, "Yummy", 'Accessing via the correct name works');
573     is ($two, undef,
574         'Accessing via a different NUL-containing name gives nothing');
575     ok (defined $one, 'defined via the correct name works');
576     ok (!defined $two,
577         'defined via a different NUL-containing name gives nothing');
578
579     $name1 = "Left"; $name2 = "Left\0Right";
580     my $glob2 = *{$name2};
581
582     is ($glob1, undef, "We get different typeglobs. In fact, undef");
583
584     *{$name1} = sub {"One"};
585     *{$name2} = sub {"Two"};
586
587     is (&{$name1}, "One");
588     is (&{$name2}, "Two");
589 }
590
591 # test derefs after list slice
592
593 is ( ({foo => "bar"})[0]{foo}, "bar", 'hash deref from list slice w/o ->' );
594 is ( ({foo => "bar"})[0]->{foo}, "bar", 'hash deref from list slice w/ ->' );
595 is ( ([qw/foo bar/])[0][1], "bar", 'array deref from list slice w/o ->' );
596 is ( ([qw/foo bar/])[0]->[1], "bar", 'array deref from list slice w/ ->' );
597 is ( (sub {"bar"})[0](), "bar", 'code deref from list slice w/o ->' );
598 is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' );
599
600 # deref on empty list shouldn't autovivify
601 {
602     local $@;
603     eval { ()[0]{foo} };
604     like ( "$@", "Can't use an undefined value as a HASH reference",
605            "deref of undef from list slice fails" );
606 }
607
608 # test dereferencing errors
609 {
610     format STDERR =
611 .
612     my $ref;
613     foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) {
614         eval q/ $$ref /;
615         like($@, qr/Not a SCALAR reference/, "Scalar dereference");
616         eval q/ @$ref /;
617         like($@, qr/Not an ARRAY reference/, "Array dereference");
618         eval q/ %$ref /;
619         like($@, qr/Not a HASH reference/, "Hash dereference");
620         eval q/ &$ref /;
621         like($@, qr/Not a CODE reference/, "Code dereference");
622     }
623
624     $ref = *STDERR{FORMAT};
625     eval q/ *$ref /;
626     like($@, qr/Not a GLOB reference/, "Glob dereference");
627
628     $ref = *STDOUT{IO};
629     eval q/ *$ref /;
630     is($@, '', "Glob dereference of PVIO is acceptable");
631
632     is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly");
633 }
634
635 # these will segfault if they fail
636
637 my $pvbm = PVBM;
638 my $rpvbm = \$pvbm;
639
640 ok (!eval { *$rpvbm }, 'PVBM ref is not a GLOB ref');
641 ok (!eval { *$pvbm }, 'PVBM is not a GLOB ref');
642 ok (!eval { $$pvbm }, 'PVBM is not a SCALAR ref');
643 ok (!eval { @$pvbm }, 'PVBM is not an ARRAY ref');
644 ok (!eval { %$pvbm }, 'PVBM is not a HASH ref');
645 ok (!eval { $pvbm->() }, 'PVBM is not a CODE ref');
646 ok (!eval { $rpvbm->foo }, 'PVBM is not an object');
647
648 # bug 24254
649 is( runperl(stderr => 1, prog => 'map eval qq(exit),1 for 1'), "");
650 is( runperl(stderr => 1, prog => 'eval { for (1) { map { die } 2 } };'), "");
651 is( runperl(stderr => 1, prog => 'for (125) { map { exit } (213)}'), "");
652 my $hushed = $^O eq 'VMS' ? 'use vmsish qw(hushed);' : '';
653 is( runperl(stderr => 1, prog => $hushed . 'map die,4 for 3'), "Died at -e line 1.\n");
654 is( runperl(stderr => 1, prog => $hushed . 'grep die,4 for 3'), "Died at -e line 1.\n");
655 is( runperl(stderr => 1, prog => $hushed . 'for $a (3) {@b=sort {die} 4,5}'), "Died at -e line 1.\n");
656
657 # bug 57564
658 is( runperl(stderr => 1, prog => 'my $i;for $i (1) { for $i (2) { } }'), "");
659
660 # The mechanism for freeing objects in globs used to leave dangling
661 # pointers to freed SVs. To test this, we construct this nested structure:
662 #    GV => blessed(AV) => RV => GV => blessed(SV)
663 # all with a refcnt of 1, and hope that the second GV gets processed first
664 # by do_clean_named_objs.  Then when the first GV is processed, it mustn't
665 # find anything nasty left by the previous GV processing.
666 # The eval is stop things in the main body of the code holding a reference
667 # to a GV, and the print at the end seems to bee necessary to ensure
668 # the correct freeing order of *x and *y (no, I don't know why - DAPM).
669
670 is (runperl(
671         prog => 'eval q[bless \@y; bless \$x; $y[0] = \*x; $z = \*y; ]; '
672                 . 'delete $::{x}; delete $::{y}; print qq{ok\n};',
673         stderr => 1),
674     "ok\n", 'freeing freed glob in global destruction');
675
676
677 # Test undefined hash references as arguments to %{} in boolean context
678 # [perl #81750]
679 {
680  no strict 'refs';
681  eval { my $foo; %$foo;             }; ok !$@, '%$undef';
682  eval { my $foo; scalar %$foo;      }; ok !$@, 'scalar %$undef';
683  eval { my $foo; !%$foo;            }; ok !$@, '!%$undef';
684  eval { my $foo; if ( %$foo) {}     }; ok !$@, 'if ( %$undef) {}';
685  eval { my $foo; if (!%$foo) {}     }; ok !$@, 'if (!%$undef) {}';
686  eval { my $foo; unless ( %$foo) {} }; ok !$@, 'unless ( %$undef) {}';
687  eval { my $foo; unless (!%$foo) {} }; ok !$@, 'unless (!%$undef) {}';
688  eval { my $foo; 1 if %$foo;        }; ok !$@, '1 if %$undef';
689  eval { my $foo; 1 if !%$foo;       }; ok !$@, '1 if !%$undef';
690  eval { my $foo; 1 unless %$foo;    }; ok !$@, '1 unless %$undef;';
691  eval { my $foo; 1 unless ! %$foo;  }; ok !$@, '1 unless ! %$undef';
692  eval { my $foo;  %$foo ? 1 : 0;    }; ok !$@, ' %$undef ? 1 : 0';
693  eval { my $foo; !%$foo ? 1 : 0;    }; ok !$@, '!%$undef ? 1 : 0';
694 }
695
696 # RT #88330
697 # Make sure that a leaked thinggy with multiple weak references to
698 # it doesn't trigger a panic with multiple rounds of global cleanup
699 # (Perl_sv_clean_all).
700
701 SKIP: {
702     skip_if_miniperl('no Scalar::Util under miniperl', 4);
703
704     local $ENV{PERL_DESTRUCT_LEVEL} = 2;
705
706     # we do all permutations of array/hash, 1ref/2ref, to account
707     # for the different way backref magic is stored
708
709     fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'array with 1 weak ref');
710 use Scalar::Util qw(weaken);
711 my $r = [];
712 Internals::SvREFCNT(@$r, 9);
713 my $r1 = $r;
714 weaken($r1);
715 print "ok";
716 EOF
717
718     fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'array with 2 weak refs');
719 use Scalar::Util qw(weaken);
720 my $r = [];
721 Internals::SvREFCNT(@$r, 9);
722 my $r1 = $r;
723 weaken($r1);
724 my $r2 = $r;
725 weaken($r2);
726 print "ok";
727 EOF
728
729     fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'hash with 1 weak ref');
730 use Scalar::Util qw(weaken);
731 my $r = {};
732 Internals::SvREFCNT(%$r, 9);
733 my $r1 = $r;
734 weaken($r1);
735 print "ok";
736 EOF
737
738     fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'hash with 2 weak refs');
739 use Scalar::Util qw(weaken);
740 my $r = {};
741 Internals::SvREFCNT(%$r, 9);
742 my $r1 = $r;
743 weaken($r1);
744 my $r2 = $r;
745 weaken($r2);
746 print "ok";
747 EOF
748
749 }
750
751 # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
752 $test = curr_test();
753 curr_test($test + 3);
754 # test global destruction
755
756 my $test1 = $test + 1;
757 my $test2 = $test + 2;
758
759 package FINALE;
760
761 {
762     $ref3 = bless ["ok $test2\n"];      # package destruction
763     my $ref2 = bless ["ok $test1\n"];   # lexical destruction
764     local $ref1 = bless ["ok $test\n"]; # dynamic destruction
765     1;                                  # flush any temp values on stack
766 }
767
768 DESTROY {
769     print $_[0][0];
770 }
771