9 use strict qw(refs subs);
14 # Test glob operations.
43 # Test fake references.
51 # Test real references.
58 # Test references to real arrays.
60 my $test = curr_test();
61 @ary = ($test,$test+1,$test+2,$test+3);
67 push(@{$ref[$i]}, "ok $ary[$i]\n");
78 # Test references to references.
82 is ($$$refref, 'Good');
84 # Test nested anonymous lists.
86 $ref = [[],2,[3,4,5,]];
89 is (${$$ref[2]}[2], 5);
90 is (scalar @{$$ref[0]}, 0);
93 is ($ref->[2]->[0], 3);
95 # Test references to hashes of references.
98 $refref->{"key"} = $ref;
99 is ($refref->{"key"}->[2]->[0], 3);
101 # Test to see if anonymous subarrays spring into existence.
103 $spring[5]->[0] = 123;
104 $spring[5]->[1] = 456;
105 push(@{$spring[5]}, 789);
106 is (join(':',@{$spring[5]}), "123:456:789");
108 # Test to see if anonymous subhashes spring into existence.
110 @{$spring2{"foo"}} = (1,2,3);
111 $spring2{"foo"}->[3] = 4;
112 is (join(':',@{$spring2{"foo"}}), "1:2:3:4");
114 # Test references to subroutines.
118 sub mysub { $called++; }
124 $subrefref = \\&mysub2;
125 is ($$subrefref->("GOOD"), "good");
126 sub mysub2 { lc shift }
128 # Test REGEXP assignment
132 my $str = "$x"; # regex stringification may change
135 is ($y, $str, "bare REGEXP stringifies correctly");
136 ok (eval { "x" =~ $y }, "bare REGEXP matches correctly");
139 ok (re::is_regexp($z), "new ref to REXEXP passes is_regexp");
140 is ($z, $str, "new ref to REGEXP stringifies correctly");
141 ok (eval { "x" =~ $z }, "new ref to REGEXP matches correctly");
150 is ($x, $str, "REGEXP keeps a ref to its mother_re");
151 ok (eval { "x" =~ $x }, "REGEXP with mother_re still matches");
154 # Test the ref operator.
156 sub PVBM () { 'foo' }
157 { my $dummy = index 'foo', PVBM }
159 my $pviv = 1; "$pviv";
160 my $pvnv = 1.0; "$pvnv";
164 # tied lvalue => SCALAR, as we haven't tested tie yet
165 # BIND, 'cos we can't create them yet
166 # REGEXP, 'cos that requires overload or Scalar::Util
167 # LVALUE ref, 'cos I can't work out how to create one :)
170 [ 'undef', SCALAR => \undef ],
171 [ 'constant IV', SCALAR => \1 ],
172 [ 'constant NV', SCALAR => \1.0 ],
173 [ 'constant PV', SCALAR => \'f' ],
174 [ 'scalar', SCALAR => \$x ],
175 [ 'PVIV', SCALAR => \$pviv ],
176 [ 'PVNV', SCALAR => \$pvnv ],
177 [ 'PVMG', SCALAR => \$0 ],
178 [ 'PVBM', SCALAR => \PVBM ],
179 [ 'vstring', VSTRING => \v1 ],
180 [ 'ref', REF => \\1 ],
181 [ 'lvalue', LVALUE => \substr($x, 0, 0) ],
182 [ 'named array', ARRAY => \@ary ],
183 [ 'anon array', ARRAY => [ 1 ] ],
184 [ 'named hash', HASH => \%whatever ],
185 [ 'anon hash', HASH => { a => 1 } ],
186 [ 'named sub', CODE => \&mysub, ],
187 [ 'anon sub', CODE => sub { 1; } ],
188 [ 'glob', GLOB => \*foo ],
189 [ 'format', FORMAT => *STDERR{FORMAT} ],
191 my ($desc, $type, $ref) = @$_;
192 is (ref $ref, $type, "ref() for ref to $desc");
193 like ("$ref", qr/^$type\(0x[0-9a-f]+\)$/, "stringify for ref to $desc");
196 is (ref *STDOUT{IO}, 'IO::Handle', 'IO refs are blessed into IO::Handle');
197 like (*STDOUT{IO}, qr/^IO::Handle=IO\(0x[0-9a-f]+\)$/,
198 'stringify for IO refs');
200 # Test anonymous hash syntax.
203 is (ref $anonhash, 'HASH');
204 $anonhash2 = {FOO => 'BAR', ABC => 'XYZ',};
205 is (join('', sort values %$anonhash2), 'BARXYZ');
207 # Test bless operator.
211 $object = bless $main'anonhash2;
212 main::is (ref $object, 'MYHASH');
213 main::is ($object->{ABC}, 'XYZ');
216 main::is (ref $object2, 'MYHASH');
218 # Test ordinary call on object method.
220 &mymethod($object,"argument");
223 local($THIS, @ARGS) = @_;
224 die 'Got a "' . ref($THIS). '" instead of a MYHASH'
225 unless ref $THIS eq 'MYHASH';
226 main::is ($ARGS[0], "argument");
227 main::is ($THIS->{FOO}, 'BAR');
230 # Test automatic destructor call.
235 $main'anonhash2 = "foo";
239 return unless $string;
240 main::is ($string, 'good');
242 # Test that the object has not already been "cursed".
243 main::isnt (ref shift, 'HASH');
246 # Now test inheritance of methods.
252 $main'object = bless {FOO => 'foo', BAR => 'bar'};
256 # Test arrow-style method invocation.
258 is ($object->doit("BAR"), 'bar');
260 # Test indirect-object-style method invocation.
262 $foo = doit $object "FOO";
263 main::is ($foo, 'foo');
267 die "Not an OBJ" unless ref $ref eq 'OBJ';
275 sub foo { main::is ($_[1], 'works') }
278 foo WHATEVER "works";
281 # test the \(@foo) construct
286 @baz = \(1,@foo,@bar);
287 is (scalar (@bar), 3);
288 is (scalar grep(ref($_), @bar), 3);
289 is (scalar (@baz), 3);
291 my(@fuu) = \(1..2,3);
293 my(@bzz) = \(1,@fuu,@baa);
294 is (scalar (@baa), 3);
295 is (scalar grep(ref($_), @baa), 3);
296 is (scalar (@bzz), 3);
298 # also, it can't be an lvalue
299 eval '\\($x, $y) = (1, 2);';
300 like ($@, qr/Can\'t modify.*ref.*in.*assignment/);
302 # test for proper destruction of lexical objects
304 sub larry::DESTROY { print "# larry\nok $test\n"; }
305 sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; }
306 sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; }
309 my ($joe, @curly, %larry);
310 my $moe = bless \$joe, 'moe';
311 my $curly = bless \@curly, 'curly';
312 my $larry = bless \%larry, 'larry';
313 print "# leaving block\n";
316 print "# left block\n";
317 curr_test($test + 3);
323 { local(*bar) = "foo" }
333 # test if reblessing during destruction results in more destruction
337 sub new { bless {}, shift }
338 DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" }
340 sub new { bless {}, shift }
341 DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' }
345 curr_test($test + 2);
347 # test if $_[0] is properly protected in DESTROY()
350 my $test = curr_test();
352 local $SIG{'__DIE__'} = sub {
355 print "# infinite recursion, bailing\nnot ok $test\n";
358 like ($m, qr/^Modification of a read-only/);
361 sub new { bless {}, shift }
362 DESTROY { $_[0] = 'foo' }
364 print "# should generate an error...\n";
367 print "# good, didn't recurse\n";
370 # test if refgen behaves with autoviv magic
382 # This test is the reason for postponed destruction in sv_unref
387 # This test used to coredump. The BEGIN block is important as it causes the
388 # op that created the constant reference to be freed. Hence the only
389 # reference to the constant string "pass" is in $a. The hack that made
390 # sure $a = $a->[1] would work didn't work with references to constants.
393 foreach my $lexical ('', 'my $a; ') {
394 my $expect = "pass\n";
395 my $result = runperl (switches => ['-wl'], stderr => 1,
396 prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a');
399 is ($result, $expect);
403 sub x::DESTROY {print "ok ", $test + shift->[0], "\n"}
404 { my $a1 = bless [3],"x";
405 my $a2 = bless [2],"x";
406 { my $a3 = bless [1],"x";
407 my $a4 = bless [0],"x";
413 is (runperl (switches=>['-l'],
414 prog=> 'print 1; print qq-*$\*-;print 1;'),
419 runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' );
420 is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//');
422 runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1);
423 is ($?, 0, 'warn called inside UNIVERSAL::DESTROY');
428 runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();');
429 is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)');
431 # bug #27268: freeing self-referential typeglobs could trigger
432 # "Attempt to free unreferenced scalar" warnings
435 prog => 'use Symbol;my $x=bless \gensym,"t"; print;*$$x=$x',
437 ), '', 'freeing self-referential typeglob');
439 # using a regex in the destructor for STDOUT segfaulted because the
440 # REGEX pad had already been freed (ithreads build only). The
441 # object is required to trigger the early freeing of GV refs to to STDOUT
444 prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}',
446 ), qr/^(ok)+$/, 'STDOUT destructor');
451 $name_utf8 = $name8 . chr 256;
454 is ($$name8, undef, 'Nothing before we start');
455 is ($$name_utf8, undef, 'Nothing before we start');
457 is ($$name8, "Pound", 'Accessing via 8 bit symref works');
458 local $TODO = "UTF8 mangled in symrefs";
459 is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works');
464 $name_utf8 = $name = chr 9787;
465 utf8::encode $name_utf8;
467 is (length $name, 1, "Name is 1 char");
468 is (length $name_utf8, 3, "UTF8 representation is 3 chars");
470 is ($$name, undef, 'Nothing before we start');
471 is ($$name_utf8, undef, 'Nothing before we start');
473 is ($$name, "Face", 'Accessing via Unicode symref works');
474 local $TODO = "UTF8 mangled in symrefs";
475 is ($$name_utf8, undef,
476 'Accessing via the UTF8 byte sequence gives nothing');
484 isnt ($name1, $name2, "They differ");
486 is ($$name1, undef, 'Nothing before we start (scalars)');
487 is ($$name2, undef, 'Nothing before we start');
489 is ($$name1, "Yummy", 'Accessing via the correct name works');
491 'Accessing via a different NUL-containing name gives nothing');
492 # defined uses a different code path
493 ok (defined $$name1, 'defined via the correct name works');
494 ok (!defined $$name2,
495 'defined via a different NUL-containing name gives nothing');
497 is ($name1->[0], undef, 'Nothing before we start (arrays)');
498 is ($name2->[0], undef, 'Nothing before we start');
499 $name1->[0] = "Yummy";
500 is ($name1->[0], "Yummy", 'Accessing via the correct name works');
501 is ($name2->[0], undef,
502 'Accessing via a different NUL-containing name gives nothing');
503 ok (defined $name1->[0], 'defined via the correct name works');
504 ok (!defined$name2->[0],
505 'defined via a different NUL-containing name gives nothing');
507 my (undef, $one) = @{$name1}[2,3];
508 my (undef, $two) = @{$name2}[2,3];
509 is ($one, undef, 'Nothing before we start (array slices)');
510 is ($two, undef, 'Nothing before we start');
511 @{$name1}[2,3] = ("Very", "Yummy");
512 (undef, $one) = @{$name1}[2,3];
513 (undef, $two) = @{$name2}[2,3];
514 is ($one, "Yummy", 'Accessing via the correct name works');
516 'Accessing via a different NUL-containing name gives nothing');
517 ok (defined $one, 'defined via the correct name works');
519 'defined via a different NUL-containing name gives nothing');
521 is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)');
522 is ($name2->{PWOF}, undef, 'Nothing before we start');
523 $name1->{PWOF} = "Yummy";
524 is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works');
525 is ($name2->{PWOF}, undef,
526 'Accessing via a different NUL-containing name gives nothing');
527 ok (defined $name1->{PWOF}, 'defined via the correct name works');
528 ok (!defined $name2->{PWOF},
529 'defined via a different NUL-containing name gives nothing');
531 my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'};
532 my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'};
533 is ($one, undef, 'Nothing before we start (hash slices)');
534 is ($two, undef, 'Nothing before we start');
535 @{$name1}{'SNIF', 'BEEYOOP'} = ("Very", "Yummy");
536 (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'};
537 (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'};
538 is ($one, "Yummy", 'Accessing via the correct name works');
540 'Accessing via a different NUL-containing name gives nothing');
541 ok (defined $one, 'defined via the correct name works');
543 'defined via a different NUL-containing name gives nothing');
545 $name1 = "Left"; $name2 = "Left\0Right";
546 my $glob2 = *{$name2};
548 is ($glob1, undef, "We get different typeglobs. In fact, undef");
550 *{$name1} = sub {"One"};
551 *{$name2} = sub {"Two"};
553 is (&{$name1}, "One");
554 is (&{$name2}, "Two");
557 # test derefs after list slice
559 is ( ({foo => "bar"})[0]{foo}, "bar", 'hash deref from list slice w/o ->' );
560 is ( ({foo => "bar"})[0]->{foo}, "bar", 'hash deref from list slice w/ ->' );
561 is ( ([qw/foo bar/])[0][1], "bar", 'array deref from list slice w/o ->' );
562 is ( ([qw/foo bar/])[0]->[1], "bar", 'array deref from list slice w/ ->' );
563 is ( (sub {"bar"})[0](), "bar", 'code deref from list slice w/o ->' );
564 is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' );
566 # deref on empty list shouldn't autovivify
570 like ( "$@", "Can't use an undefined value as a HASH reference",
571 "deref of undef from list slice fails" );
574 # test dereferencing errors
579 foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) {
581 like($@, qr/Not a SCALAR reference/, "Scalar dereference");
583 like($@, qr/Not an ARRAY reference/, "Array dereference");
585 like($@, qr/Not a HASH reference/, "Hash dereference");
587 like($@, qr/Not a CODE reference/, "Code dereference");
590 $ref = *STDERR{FORMAT};
592 like($@, qr/Not a GLOB reference/, "Glob dereference");
596 is($@, '', "Glob dereference of PVIO is acceptable");
598 is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly");
601 # these will segfault if they fail
606 ok (!eval { *$rpvbm }, 'PVBM ref is not a GLOB ref');
607 ok (!eval { *$pvbm }, 'PVBM is not a GLOB ref');
608 ok (!eval { $$pvbm }, 'PVBM is not a SCALAR ref');
609 ok (!eval { @$pvbm }, 'PVBM is not an ARRAY ref');
610 ok (!eval { %$pvbm }, 'PVBM is not a HASH ref');
611 ok (!eval { $pvbm->() }, 'PVBM is not a CODE ref');
612 ok (!eval { $rpvbm->foo }, 'PVBM is not an object');
615 is( runperl(stderr => 1, prog => 'map eval qq(exit),1 for 1'), "");
616 is( runperl(stderr => 1, prog => 'eval { for (1) { map { die } 2 } };'), "");
617 is( runperl(stderr => 1, prog => 'for (125) { map { exit } (213)}'), "");
618 my $hushed = $^O eq 'VMS' ? 'use vmsish qw(hushed);' : '';
619 is( runperl(stderr => 1, prog => $hushed . 'map die,4 for 3'), "Died at -e line 1.\n");
620 is( runperl(stderr => 1, prog => $hushed . 'grep die,4 for 3'), "Died at -e line 1.\n");
621 is( runperl(stderr => 1, prog => $hushed . 'for $a (3) {@b=sort {die} 4,5}'), "Died at -e line 1.\n");
624 is( runperl(stderr => 1, prog => 'my $i;for $i (1) { for $i (2) { } }'), "");
627 # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
629 curr_test($test + 3);
630 # test global destruction
632 my $test1 = $test + 1;
633 my $test2 = $test + 2;
638 $ref3 = bless ["ok $test2\n"]; # package destruction
639 my $ref2 = bless ["ok $test1\n"]; # lexical destruction
640 local $ref1 = bless ["ok $test\n"]; # dynamic destruction
641 1; # flush any temp values on stack