ref.t revision 7c478bd95313f5f23a4c958a745db2134aa03244
#!./perl
BEGIN {
chdir 't' if -d 't';
}
print "1..69\n";
require 'test.pl';
# Test glob operations.
$bar = "ok 1\n";
$foo = "ok 2\n";
{
print $foo;
}
print $foo;
$baz = "ok 3\n";
$foo = "ok 4\n";
{
print $foo;
}
print $foo;
$foo = "ok 6\n";
{
print $foo;
print $foo;
}
print $foo;
# Test fake references.
$baz = "ok 7\n";
$bar = 'baz';
$foo = 'bar';
print $$$foo;
# Test real references.
$BAZ = "ok 8\n";
print $$$FOO;
# Test references to real arrays.
@ary = (9,10,11,12);
$ref[0] = \@a;
$ref[1] = \@b;
$ref[2] = \@c;
$ref[3] = \@d;
for $i (3,1,2,0) {
}
print @a;
print @{'d'};
# Test references to references.
$refref = \\$x;
$x = "ok 13\n";
print $$$refref;
# Test nested anonymous lists.
# Test references to hashes of references.
# Test to see if anonymous subarrays spring into existence.
# Test to see if anonymous subhashes spring into existence.
# Test references to subroutines.
&$subref;
$subrefref = \\&mysub2;
sub mysub2 { print shift }
# Test the ref operator.
# Test anonymous hash syntax.
$anonhash = {};
$anonhash2 = {FOO => BAR, ABC => XYZ,};
# Test bless operator.
print ref $object eq MYHASH ? "ok 30\n" : "not ok 30\n";
print $object->{ABC} eq XYZ ? "ok 31\n" : "not ok 31\n";
$object2 = bless {};
print ref $object2 eq MYHASH ? "ok 32\n" : "not ok 32\n";
# Test ordinary call on object method.
&mymethod($object,33);
sub mymethod {
local($THIS, @ARGS) = @_;
unless ref $THIS eq MYHASH;
print $THIS->{FOO} eq BAR ? "ok $ARGS[0]\n" : "not ok $ARGS[0]\n";
}
# Test automatic destructor call.
$string = "not ok 34\n";
$object = "foo";
$string = "ok 34\n";
DESTROY {
print $string;
# Test that the object has not already been "cursed".
}
# Now test inheritance of methods.
$main'object = bless {FOO => foo, BAR => bar};
package main;
# Test arrow-style method invocation.
print $object->doit("BAR") eq bar ? "ok 36\n" : "not ok 36\n";
# Test indirect-object-style method invocation.
$foo = doit $object "FOO";
print $foo eq foo ? "ok 37\n" : "not ok 37\n";
local $ref = shift;
}
sub foo { print $_[1] }
#
# test the \(@foo) construct
#
@foo = \(1..3);
# also, it can't be an lvalue
eval '\\($x, $y) = (1, 2);';
# test for proper destruction of lexical objects
{
print "# leaving block\n";
}
print "# left block\n";
# another glob test
$_ = \$var;
print $$_,"\n";
# test if reblessing during destruction results in more destruction
{
package A;
}
# test if $_[0] is properly protected in DESTROY()
{
my $i = 0;
my $m = shift;
if ($i++ > 4) {
print "# infinite recursion, bailing\nnot ok 53\n";
exit 1;
}
print "# $m";
};
package C;
{
print "# should generate an error...\n";
my $c = C->new;
}
print "# good, didn't recurse\n";
}
# test if refgen behaves with autoviv magic
{
my @a;
$a[1] = "ok 54\n";
print ${\$_} for @a;
}
# This test is the reason for postponed destruction in sv_unref
$a = [1,2,3];
$a = $a->[1];
print "ok 55\n";
# This test used to coredump. The BEGIN block is important as it causes the
# op that created the constant reference to be freed. Hence the only
# reference to the constant string "pass" is in $a. The hack that made
# sure $a = $a->[1] would work didn't work with references to constants.
my $test = 56;
} else {
}
$test++;
}
567;
}
}
$test+=4;
} else {
}
}
# bug #21347
if ($? != 0) { print "not " };
if ($? != 0) { print "not " };
# bug #22719
if ($? != 0) { print "not " };
# bug #27268: freeing self-referential typeglobs could trigger
# "Attempt to free unreferenced scalar" warnings
stderr => 1
);
# test global destruction
++$test;
{
1; # flush any temp values on stack
}
DESTROY {
print $_[0][0];
}