Re: A new PerlIO coredump

[p5sagit/p5-mst-13.2.git] / t / lib / u-weak.t

BEGIN {
	chdir 't' if -d 't';
	@INC = '../lib';
}

BEGIN {
  $|=1;
  require Scalar::Util;
  if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
    print("1..0\n");
    exit;
  }

  $DEBUG = 0;

  if ($DEBUG && eval { require Devel::Peek } ) {
    Devel::Peek->import('Dump');
  }
  else {
    *Dump = sub {};
  }
}

use Scalar::Util qw(weaken isweak);
print "1..17\n";

######################### End of black magic.

$cnt = 0;

sub ok {
	++$cnt;
	if($_[0]) { print "ok $cnt\n"; } else {print "not ok $cnt\n"; }
}

$| = 1;

if(1) {

my ($y,$z);

#
# Case 1: two references, one is weakened, the other is then undef'ed.
#

{
	my $x = "foo";
	$y = \$x;
	$z = \$x;
}
print "# START:\n";
Dump($y); Dump($z);

ok( $y ne "" and $z ne "" );
weaken($y);

print "# WEAK:\n";
Dump($y); Dump($z);

ok( $y ne "" and $z ne "" );
undef($z);

print "# UNDZ:\n";
Dump($y); Dump($z);

ok( not (defined($y) and defined($z)) );
undef($y);

print "# UNDY:\n";
Dump($y); Dump($z);

ok( not (defined($y) and defined($z)) );

print "# FIN:\n";
Dump($y); Dump($z);

# exit(0);

# }
# {

# 
# Case 2: one reference, which is weakened
#

# kill 5,$$;

print "# CASE 2:\n";

{
	my $x = "foo";
	$y = \$x;
}

ok( $y ne "" );
print "# BW: \n";
Dump($y);
weaken($y);
print "# AW: \n";
Dump($y);
ok( not defined $y  );

print "# EXITBLOCK\n";
}

# exit(0);

# 
# Case 3: a circular structure
#

# kill 5, $$;

$flag = 0;
{
	my $y = bless {}, Dest;
	Dump($y);
	print "# 1: $y\n";
	$y->{Self} = $y;
	Dump($y);
	print "# 2: $y\n";
	$y->{Flag} = \$flag;
	print "# 3: $y\n";
	weaken($y->{Self});
	print "# WKED\n";
	ok( $y ne "" );
	print "# VALS: HASH ",$y,"   SELF ",\$y->{Self},"  Y ",\$y, 
		"    FLAG: ",\$y->{Flag},"\n";
	print "# VPRINT\n";
}
print "# OUT $flag\n";
ok( $flag == 1 );

print "# AFTER\n";

undef $flag;

print "# FLAGU\n";

#
# Case 4: a more complicated circular structure
#

$flag = 0;
{
	my $y = bless {}, Dest;
	my $x = bless {}, Dest;
	$x->{Ref} = $y;
	$y->{Ref} = $x;
	$x->{Flag} = \$flag;
	$y->{Flag} = \$flag;
	weaken($x->{Ref});
}
ok( $flag == 2 );

#
# Case 5: deleting a weakref before the other one
#

{
	my $x = "foo";
	$y = \$x;
	$z = \$x;
}

print "# CASE5\n";
Dump($y);

weaken($y);
Dump($y);
undef($y);

ok( not defined $y);
ok($z ne "");


#
# Case 6: test isweakref
#

$a = 5;
ok(!isweak($a));
$b = \$a;
ok(!isweak($b));
weaken($b);
ok(isweak($b));
$b = \$a;
ok(!isweak($b));

$x = {};
weaken($x->{Y} = \$a);
ok(isweak($x->{Y}));
ok(!isweak($x->{Z}));


package Dest;

sub DESTROY {
	print "# INCFLAG\n";
	${$_[0]{Flag}} ++;
}