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