This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In buildtoc, eliminate the now vestigial sub output.
[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
5e307270 12plan(200);
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
5e307270
FC
379# test that DESTROY is called on all objects during global destruction,
380# even those without hard references [perl #36347]
381
382is(
383 runperl(
c1b879e5 384 stderr => 1, prog => 'sub DESTROY { print qq-aaa\n- } bless \$a[0]'
5e307270 385 ),
c1b879e5 386 "aaa\n", 'DESTROY called on array elem'
5e307270
FC
387);
388is(
389 runperl(
390 stderr => 1,
c1b879e5 391 prog => '{ bless \my@x; *a=sub{@x}}sub DESTROY { print qq-aaa\n- }'
5e307270 392 ),
c1b879e5 393 "aaa\n",
5e307270
FC
394 'DESTROY called on closure variable'
395);
396
397
0dd88869 398# test if refgen behaves with autoviv magic
0dd88869
GS
399{
400 my @a;
805232b4
NC
401 $a[1] = "good";
402 my $got;
403 for (@a) {
404 $got .= ${\$_};
405 $got .= ';';
406 }
407 is ($got, ";good;");
0dd88869
GS
408}
409
840a7b70
IZ
410# This test is the reason for postponed destruction in sv_unref
411$a = [1,2,3];
412$a = $a->[1];
805232b4 413is ($a, 2);
840a7b70 414
04ca4930
NC
415# This test used to coredump. The BEGIN block is important as it causes the
416# op that created the constant reference to be freed. Hence the only
417# reference to the constant string "pass" is in $a. The hack that made
418# sure $a = $a->[1] would work didn't work with references to constants.
419
04ca4930
NC
420
421foreach my $lexical ('', 'my $a; ') {
422 my $expect = "pass\n";
423 my $result = runperl (switches => ['-wl'], stderr => 1,
424 prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a');
425
805232b4
NC
426 is ($?, 0);
427 is ($result, $expect);
840a7b70
IZ
428}
429
e24631be 430$test = curr_test();
04ca4930
NC
431sub x::DESTROY {print "ok ", $test + shift->[0], "\n"}
432{ my $a1 = bless [3],"x";
433 my $a2 = bless [2],"x";
434 { my $a3 = bless [1],"x";
435 my $a4 = bless [0],"x";
436 567;
437 }
438}
805232b4
NC
439curr_test($test+4);
440
441is (runperl (switches=>['-l'],
442 prog=> 'print 1; print qq-*$\*-;print 1;'),
443 "1\n*\n*\n1\n");
b2ce0fda 444
39cff0d9
AE
445# bug #21347
446
447runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' );
805232b4 448is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//');
39cff0d9 449
7b102d90 450runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1);
805232b4 451is ($?, 0, 'warn called inside UNIVERSAL::DESTROY');
7b102d90 452
23bb1b96
DM
453
454# bug #22719
455
456runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();');
805232b4 457is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)');
23bb1b96 458
ec5f3c78
DM
459# bug #27268: freeing self-referential typeglobs could trigger
460# "Attempt to free unreferenced scalar" warnings
461
805232b4 462is (runperl(
3d7a9343 463 prog => 'use Symbol;my $x=bless \gensym,q{t}; print;*$$x=$x',
ec5f3c78 464 stderr => 1
805232b4 465), '', 'freeing self-referential typeglob');
23bb1b96 466
804ffa60
DM
467# using a regex in the destructor for STDOUT segfaulted because the
468# REGEX pad had already been freed (ithreads build only). The
469# object is required to trigger the early freeing of GV refs to to STDOUT
470
ff26e4c8
CB
471TODO: {
472 local $TODO = "works but output through pipe is mangled" if $^O eq 'VMS';
473 like (runperl(
3d7a9343 474 prog => '$x=bless[]; sub IO::Handle::DESTROY{$_=q{bad};s/bad/ok/;print}',
ff26e4c8
CB
475 stderr => 1
476 ), qr/^(ok)+$/, 'STDOUT destructor');
477}
804ffa60 478
512d1826
NC
479TODO: {
480 no strict 'refs';
481 $name8 = chr 163;
482 $name_utf8 = $name8 . chr 256;
483 chop $name_utf8;
484
485 is ($$name8, undef, 'Nothing before we start');
486 is ($$name_utf8, undef, 'Nothing before we start');
487 $$name8 = "Pound";
488 is ($$name8, "Pound", 'Accessing via 8 bit symref works');
489 local $TODO = "UTF8 mangled in symrefs";
490 is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works');
491}
492
493TODO: {
494 no strict 'refs';
495 $name_utf8 = $name = chr 9787;
496 utf8::encode $name_utf8;
497
498 is (length $name, 1, "Name is 1 char");
499 is (length $name_utf8, 3, "UTF8 representation is 3 chars");
500
501 is ($$name, undef, 'Nothing before we start');
502 is ($$name_utf8, undef, 'Nothing before we start');
503 $$name = "Face";
504 is ($$name, "Face", 'Accessing via Unicode symref works');
505 local $TODO = "UTF8 mangled in symrefs";
506 is ($$name_utf8, undef,
507 'Accessing via the UTF8 byte sequence gives nothing');
508}
509
431529db 510{
512d1826
NC
511 no strict 'refs';
512 $name1 = "\0Chalk";
513 $name2 = "\0Cheese";
514
515 isnt ($name1, $name2, "They differ");
516
431529db 517 is ($$name1, undef, 'Nothing before we start (scalars)');
512d1826 518 is ($$name2, undef, 'Nothing before we start');
b3d904f3 519 $$name1 = "Yummy";
512d1826 520 is ($$name1, "Yummy", 'Accessing via the correct name works');
512d1826
NC
521 is ($$name2, undef,
522 'Accessing via a different NUL-containing name gives nothing');
fc4809d7
NC
523 # defined uses a different code path
524 ok (defined $$name1, 'defined via the correct name works');
525 ok (!defined $$name2,
526 'defined via a different NUL-containing name gives nothing');
431529db
NC
527
528 is ($name1->[0], undef, 'Nothing before we start (arrays)');
529 is ($name2->[0], undef, 'Nothing before we start');
530 $name1->[0] = "Yummy";
531 is ($name1->[0], "Yummy", 'Accessing via the correct name works');
532 is ($name2->[0], undef,
533 'Accessing via a different NUL-containing name gives nothing');
fc4809d7
NC
534 ok (defined $name1->[0], 'defined via the correct name works');
535 ok (!defined$name2->[0],
536 'defined via a different NUL-containing name gives nothing');
431529db
NC
537
538 my (undef, $one) = @{$name1}[2,3];
539 my (undef, $two) = @{$name2}[2,3];
540 is ($one, undef, 'Nothing before we start (array slices)');
541 is ($two, undef, 'Nothing before we start');
542 @{$name1}[2,3] = ("Very", "Yummy");
543 (undef, $one) = @{$name1}[2,3];
544 (undef, $two) = @{$name2}[2,3];
545 is ($one, "Yummy", 'Accessing via the correct name works');
546 is ($two, undef,
547 'Accessing via a different NUL-containing name gives nothing');
fc4809d7
NC
548 ok (defined $one, 'defined via the correct name works');
549 ok (!defined $two,
550 'defined via a different NUL-containing name gives nothing');
431529db
NC
551
552 is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)');
553 is ($name2->{PWOF}, undef, 'Nothing before we start');
554 $name1->{PWOF} = "Yummy";
555 is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works');
556 is ($name2->{PWOF}, undef,
557 'Accessing via a different NUL-containing name gives nothing');
fc4809d7
NC
558 ok (defined $name1->{PWOF}, 'defined via the correct name works');
559 ok (!defined $name2->{PWOF},
560 'defined via a different NUL-containing name gives nothing');
431529db
NC
561
562 my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'};
563 my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'};
564 is ($one, undef, 'Nothing before we start (hash slices)');
565 is ($two, undef, 'Nothing before we start');
566 @{$name1}{'SNIF', 'BEEYOOP'} = ("Very", "Yummy");
567 (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'};
568 (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'};
569 is ($one, "Yummy", 'Accessing via the correct name works');
570 is ($two, undef,
571 'Accessing via a different NUL-containing name gives nothing');
fc4809d7
NC
572 ok (defined $one, 'defined via the correct name works');
573 ok (!defined $two,
574 'defined via a different NUL-containing name gives nothing');
431529db
NC
575
576 $name1 = "Left"; $name2 = "Left\0Right";
577 my $glob2 = *{$name2};
578
88e5f542 579 is ($glob1, undef, "We get different typeglobs. In fact, undef");
780a5241
NC
580
581 *{$name1} = sub {"One"};
582 *{$name2} = sub {"Two"};
583
584 is (&{$name1}, "One");
585 is (&{$name2}, "Two");
512d1826
NC
586}
587
9a9798c2
YST
588# test derefs after list slice
589
590is ( ({foo => "bar"})[0]{foo}, "bar", 'hash deref from list slice w/o ->' );
591is ( ({foo => "bar"})[0]->{foo}, "bar", 'hash deref from list slice w/ ->' );
592is ( ([qw/foo bar/])[0][1], "bar", 'array deref from list slice w/o ->' );
593is ( ([qw/foo bar/])[0]->[1], "bar", 'array deref from list slice w/ ->' );
594is ( (sub {"bar"})[0](), "bar", 'code deref from list slice w/o ->' );
595is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' );
596
597# deref on empty list shouldn't autovivify
598{
599 local $@;
600 eval { ()[0]{foo} };
601 like ( "$@", "Can't use an undefined value as a HASH reference",
602 "deref of undef from list slice fails" );
603}
604
cbae9b9f
YST
605# test dereferencing errors
606{
2d905216
NC
607 format STDERR =
608.
609 my $ref;
610 foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) {
611 eval q/ $$ref /;
612 like($@, qr/Not a SCALAR reference/, "Scalar dereference");
613 eval q/ @$ref /;
614 like($@, qr/Not an ARRAY reference/, "Array dereference");
615 eval q/ %$ref /;
616 like($@, qr/Not a HASH reference/, "Hash dereference");
617 eval q/ &$ref /;
618 like($@, qr/Not a CODE reference/, "Code dereference");
619 }
620
621 $ref = *STDERR{FORMAT};
622 eval q/ *$ref /;
623 like($@, qr/Not a GLOB reference/, "Glob dereference");
624
625 $ref = *STDOUT{IO};
626 eval q/ *$ref /;
627 is($@, '', "Glob dereference of PVIO is acceptable");
628
629 is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly");
cbae9b9f
YST
630}
631
6e592b3a
BM
632# these will segfault if they fail
633
634my $pvbm = PVBM;
635my $rpvbm = \$pvbm;
636
637ok (!eval { *$rpvbm }, 'PVBM ref is not a GLOB ref');
638ok (!eval { *$pvbm }, 'PVBM is not a GLOB ref');
639ok (!eval { $$pvbm }, 'PVBM is not a SCALAR ref');
640ok (!eval { @$pvbm }, 'PVBM is not an ARRAY ref');
641ok (!eval { %$pvbm }, 'PVBM is not a HASH ref');
642ok (!eval { $pvbm->() }, 'PVBM is not a CODE ref');
643ok (!eval { $rpvbm->foo }, 'PVBM is not an object');
644
fcf99ed4
B
645# bug 24254
646is( runperl(stderr => 1, prog => 'map eval qq(exit),1 for 1'), "");
647is( runperl(stderr => 1, prog => 'eval { for (1) { map { die } 2 } };'), "");
648is( runperl(stderr => 1, prog => 'for (125) { map { exit } (213)}'), "");
54c717c3
CB
649my $hushed = $^O eq 'VMS' ? 'use vmsish qw(hushed);' : '';
650is( runperl(stderr => 1, prog => $hushed . 'map die,4 for 3'), "Died at -e line 1.\n");
651is( runperl(stderr => 1, prog => $hushed . 'grep die,4 for 3'), "Died at -e line 1.\n");
652is( runperl(stderr => 1, prog => $hushed . 'for $a (3) {@b=sort {die} 4,5}'), "Died at -e line 1.\n");
fcf99ed4
B
653
654# bug 57564
655is( runperl(stderr => 1, prog => 'my $i;for $i (1) { for $i (2) { } }'), "");
656
57ef47cc
DM
657# The mechanism for freeing objects in globs used to leave dangling
658# pointers to freed SVs. To test this, we construct this nested structure:
659# GV => blessed(AV) => RV => GV => blessed(SV)
660# all with a refcnt of 1, and hope that the second GV gets processed first
661# by do_clean_named_objs. Then when the first GV is processed, it mustn't
93f09d7b 662# find anything nasty left by the previous GV processing.
57ef47cc
DM
663# The eval is stop things in the main body of the code holding a reference
664# to a GV, and the print at the end seems to bee necessary to ensure
665# the correct freeing order of *x and *y (no, I don't know why - DAPM).
666
667is (runperl(
668 prog => 'eval q[bless \@y; bless \$x; $y[0] = \*x; $z = \*y; ]; '
bf70f410 669 . 'delete $::{x}; delete $::{y}; print qq{ok\n};',
57ef47cc
DM
670 stderr => 1),
671 "ok\n", 'freeing freed glob in global destruction');
672
fcf99ed4 673
805232b4
NC
674# Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
675$test = curr_test();
676curr_test($test + 3);
4e8e7886
GS
677# test global destruction
678
840a7b70
IZ
679my $test1 = $test + 1;
680my $test2 = $test + 2;
681
8990e307
LW
682package FINALE;
683
684{
840a7b70
IZ
685 $ref3 = bless ["ok $test2\n"]; # package destruction
686 my $ref2 = bless ["ok $test1\n"]; # lexical destruction
687 local $ref1 = bless ["ok $test\n"]; # dynamic destruction
8990e307
LW
688 1; # flush any temp values on stack
689}
690
691DESTROY {
692 print $_[0][0];
693}
804ffa60 694