#!/usr/bin/perl -I../lib -I..

use warnings;
use strict;

#
# these are tests that confirm how perl works.
#

use Scalar::Util qw(refaddr reftype blessed);
use Test::More tests => 85;

#
# I can't find a case where a delete doesn't
# at least cause a change in the reference
# (if not the refaddr)
#

print "# block at ".__LINE__."\n";

{
	my (%x) = ( x => 7 );
	my $a = \$x{x};
	delete $x{x};
	my $b = \$x{x};
	$x{x} = 9;
	my $c = \$x{x};

	ok ( $a ne $b );
	ok ( $a ne $c );
	ok ( $b eq $c );
	ok ( refaddr($a) ne refaddr($b) );
}


#
# Nearly any other code sequnce cause the
# refaddr to change too
#

print "# block at ".__LINE__."\n";

{
	my (%x) = ( x => 7 );
	my $a = refaddr(\$x{x});
	my $ar = \$x{x};
	delete $x{x};
	my $b = refaddr(\$x{x});
	my $br = \$x{x};
	$x{x} = 9;
	my $c = refaddr(\$x{x});
	my $cr = \$x{x};

	ok ( $a ne $b );
	ok ( $a ne $c );
	ok ( $b eq $c );
	ok ( $ar ne $br );
	ok ( $br eq $cr );
	ok ( $$cr == 9 );
	ok ( $$ar == 7 );
}

#
# ditto.
#

print "# block at ".__LINE__."\n";

{
	my (%x) = ( x => 7 );
	my $ar = \$x{x};
	my $a = refaddr($ar);
	delete $x{x};
	my $br = \$x{x};
	my $b = refaddr($br);
	$x{x} = 9;
	my $cr = \$x{x};
	my $c = refaddr($cr);

	ok ( $a ne $b );
	ok ( $a ne $c );
	ok ( $b eq $c );
	ok ( $ar ne $br );
	ok ( $br eq $cr );
	ok ( $$cr == 9 );
	ok ( $$ar == 7 );
}


# 
# ditto.
#

print "# block at ".__LINE__."\n";

{
	my $x;
	my ($ar) = \$x;
	my ($br) = \$x;
	my ($cr) = \$x;
	my (%x) = ( x => 7 );
	my $a = refaddr(\$x{x});
	$ar = \$x{x};
	delete $x{x};
	my $b = refaddr(\$x{x});
	$br = \$x{x};
	$x{x} = 9;
	my $c = refaddr(\$x{x});
	$cr = \$x{x};

	ok ( $a ne $b );
	ok ( $b eq $c );
}

#
# repeat: refaddrs change when keys are deleted
# refaddr and references don't change when keys aren't deleted
#

print "# block at ".__LINE__."\n";

{
	my (%x) = ( y => 7 );
	my $a = \$x{x};
	my $a1 = $$a;
	$x{x} = 9;
	my $a2 = $$a;
	my $b = \$x{x};
	my $b1 = $$b;
	delete $x{x};
	my $c = \$x{x};

	ok (refaddr($a) eq refaddr($b));
	ok (refaddr($a) ne refaddr($c));
	ok ( !defined($a1));
	ok ($a2 == 9);
	ok ($b1 == 9);
}

#
# repeat: making a reference creates a hash key
# repeat: delting a reference orphans a key
#

print "# block at ".__LINE__."\n";

{
	my (%x) = ( y => 7 );

	ok (! exists($x{x}));

	my $a = \$x{x};

	ok (exists($x{x}));

	my $a1 = $$a;
	$x{x} = 9;
	my $a2 = $$a;
	my $b = \$x{x};
	my $b1 = $$b;

	delete $x{x};

	ok (! exists($x{x}));

	my $c = \$x{x};

	ok (exists($x{x}));
}

#
# EXCEPT!  When a hash key is deleted
# sometimes the refaddr doesn't change.
# This appears to be a rare case.
#
# I think this works this way because 
# the reference isn't kept and the new
# one just happens to get the same memory
# location.
#

print "# block at ".__LINE__."\n";

{
	my (%x) = ( x => 7 );
	my $a = refaddr(\$x{x});
	delete $x{x};
	my $b = refaddr(\$x{x});
	$x{x} = 9;
	my $c = refaddr(\$x{x});

	ok ( $a eq $b );
	ok ( $a eq $c );
	ok ( $b eq $c );
}

#
# EXCEPT!  When a hash key is deleted
# sometimes the refaddr doesn't change.
# This appears to be a rare case.
#
# I think this works this way because 
# the reference isn't kept and the new
# one just happens to get the same memory
# location.
#

print "# block at ".__LINE__."\n";

{
	my %x;
	my %y;
	tie %x, 'Hash1', \%y;
	$x{x} = 7;

	my $a = refaddr(\$x{x});
	delete $x{x};
	my $b = refaddr(\$x{x});
	$x{x} = 9;
	my $c = refaddr(\$x{x});

	ok ( $a eq $b );
	ok ( $a eq $c );
	ok ( $b eq $c );
}

#
# Tied references to hash values that don't exist
# don't refer to the future value (once it does exist)
#

print "# block at ".__LINE__."\n";

{
	my %x;
	my %y;
	tie %x, 'Hash1', \%y;

	$x{x} = 7;
	my $a = \$x{x};
	delete $x{x};
	my $b = \$x{x};
	$x{x} = 9;
	my $c = \$x{x};

	ok ( $a ne $b );
	ok ( $a ne $c );
	TODO: {
		local $TODO = "TIE doesn't support lvalue return";
		ok ( $b eq $c );
	}
	ok ( refaddr($a) ne refaddr($b) );
}

#
# Nearly any other code sequnce cause the
# refaddr to change too
#

print "# block at ".__LINE__."\n";

{
	my %x;
	my %y;
	tie %x, 'Hash1', \%y;
	$x{x} = 7;

	my $a = refaddr(\$x{x});
	my $ar = \$x{x};
	delete $x{x};
	my $b = refaddr(\$x{x});
	my $br = \$x{x};
	$x{x} = 9;
	my $c = refaddr(\$x{x});
	my $cr = \$x{x};

	ok ( $a ne $b );
	ok ( $a ne $c );
	ok ( $$cr == 9 );
	ok ( $$br == 9 );
	ok ( $ar ne $br );
	TODO: {
		local $TODO = "TIE doesn't support lvalue return";
		ok ( $b eq $c );
		ok ( $br eq $cr );
		ok ( $$ar == 7 );
	}
}

#
# ditto.
#

print "# block at ".__LINE__."\n";

{
	my %x;
	my %y;
	tie %x, 'Hash1', \%y;
	$x{x} = 7;

	my $ar = \$x{x};
	my $a = refaddr($ar);
	delete $x{x};
	my $br = \$x{x};
	my $b = refaddr($br);
	$x{x} = 9;
	my $cr = \$x{x};
	my $c = refaddr($cr);

	ok ( $a ne $b );
	ok ( $a ne $c );
	ok ( $ar ne $br );
	ok ( $$cr == 9 );
	ok ( $$br == 9 );
	TODO: {
		local $TODO = "TIE doesn't support lvalue return";
		ok ( $$ar == 7 );
		ok ( $br eq $cr );
		ok ( $b eq $c );
	}
}


# 
# ditto.
#

print "# block at ".__LINE__."\n";

{
	my $x;
	my ($ar) = \$x;
	my ($br) = \$x;
	my ($cr) = \$x;

	my %x;
	my %y;
	tie %x, 'Hash1', \%y;
	$x{x} = 7;

	my $a = refaddr(\$x{x});
	$ar = \$x{x};
	delete $x{x};
	my $b = refaddr(\$x{x});
	$br = \$x{x};
	$x{x} = 9;
	my $c = refaddr(\$x{x});
	$cr = \$x{x};

	ok ( $a ne $b );
	TODO: {
		local $TODO = "TIE doesn't support lvalue return";
		ok ( $b eq $c );
	}
}

print "# block at ".__LINE__."\n";

#
# Making an alias causes an hash key to exist.
#

{
	my %x;
	my %y;
	tie %x, 'Hash1', \%y;
	$x{y} = 7;

	my $a = refaddr(\$x{x});

	TODO: {
		local $TODO = "TIE doesn't support lvalue return";
		ok ( exists $x{x});
	}
}

#
# Deleting a hash key causes it's refaddr to
# changed.
#

print "# block at ".__LINE__."\n";

{
	my %x;
	my %y;
	tie %x, 'Hash1', \%y;

	$x{y} = 7;
	my $a = refaddr(\$x{x});
	$x{x} = 9;
	my $b = refaddr(\$x{x});
	delete $x{x};
	$x{zyz} = 77;
	my $dummy = \$x{xyz};
	my $c = refaddr(\$x{x});

	ok ( $a eq $b );
	ok ( $a ne $c );
	TODO: {
		local $TODO = "TIE doesn't support lvalue return";
		ok ( exists $x{x});
	}
}

#
# repeat: refaddrs change when keys are deleted
# refaddr and references don't change when keys aren't deleted
#

print "# block at ".__LINE__."\n";

{
	my %x;
	my %y;
	tie %x, 'Hash1', \%y;
	$x{y} = 7;

	my $a = \$x{x};
	my $a1 = $$a;
	$x{x} = 9;
	my $a2 = $$a;
	my $b = \$x{x};
	my $b1 = $$b;
	delete $x{x};
	my $c = \$x{x};

	ok (refaddr($a) ne refaddr($c));
	ok ( !defined($a1));
	ok ($b1 == 9);
	TODO: {
		local $TODO = "TIE doesn't support lvalue return";
		ok (refaddr($a) eq refaddr($b));
		ok (defined($a2) && $a2 == 9);
	}
}

#
# repeat: making a reference creates a hash key
# repeat: delting a reference orphans a key
#

print "# block at ".__LINE__."\n";

{
	my %x;
	my %y;
	tie %x, 'Hash1', \%y;
	$x{y} = 7;

	ok (! exists($x{x}));

	my $a = \$x{x};

	TODO: {
		local $TODO = "TIE doesn't support lvalue return";
		ok (exists($x{x}));
	}

	my $a1 = $$a;
	$x{x} = 9;
	my $a2 = $$a;
	my $b = \$x{x};
	my $b1 = $$b;

	delete $x{x};

	ok (! exists($x{x}));

	my $c = \$x{x};

	TODO: {
		local $TODO = "TIE doesn't support lvalue return";
		ok (exists($x{x}));
	}
}

print "# block at ".__LINE__."\n";

{
	my %x;
	$x{x} = 7;
	$x{y} = 8;
	my $a = \$x{x};
	my $b = \$a;
	$a = \$x{y};

	ok(${${$b}} == 8);
}

if (0) {
	tie my %x, 'Hash1', {};

	$x{y} = 7;
	my $a = \$x{A_KEY_WAS_FOUND};

	my $sv = svref_2object($a);
	print "ref(sv)         : ".ref($sv)."\n";
	print "MAGICAL(sv)     : ".$sv->MAGICAL."\n";
	print "FLAGS(sv)       : ".$sv->FLAGS."\n";
	print "TARG(sv)        : ".$sv->TARG."\n";
	print "STASH(sv)       : ".$sv->SvSTASH."\n";
	print "ref(MAGICAL(sv)): ".ref($sv->MAGICAL)."\n";
	print "ref(FLAGS(sv))  : ".ref($sv->FLAGS)."\n";
	print "ref(STASH(sv))  : ".ref($sv->SvSTASH)."\n";
	print "ref(TARG(sv))   : ".ref($sv->TARG)."\n";
	print "sv->TARG->      : ".${$sv->TARG}."\n";
	print "sv->STASH->     : ".${$sv->SvSTASH}."\n";
	print "sv              : $$sv\n";
	my $svx = $sv->MAGIC;
	print "ref(svx)        : ".ref($svx)."\n";
	#print "MAGICAL(svx)    : ".$svx->MAGICAL."\n";
	print "svx             : $$svx\n";
	while (lc($svx->TYPE) ne 'p') {
		print "type: ".$svx->TYPE."\n";
		$svx = $svx->MOREMAGIC;
	}
	print "svx->TYPE       : ".$svx->TYPE."\n";
	print "svx->OBJ        : ".$svx->OBJ."\n";
	print "svx->PTR        : ".$svx->PTR."\n";
	print "svx->PTR->str   : ".$svx->PTR->as_string."\n";
	print "svx->OBJ->RV    : ".${$svx->OBJ->RV}."\n";
	print "ref(svx->PTR)   : ".ref($svx->PTR)."\n";
	my $ob = $svx->OBJ;
	print "ref(ob)         : ".ref($ob)."\n";
	print "ref(ob)->       : ".$$ob."\n";
	print "refaddr tied %x : ". refaddr(tied %x)."\n";
	print "refaddr      \\%x: ". refaddr(\%x)."\n";
}

if (0) {
	print "methods(B::PVLV) =\n\t".join("\n\t",methods('B::PVLV'))."\n";
	print "methods(B::RV) =\n\t".join("\n\t",methods('B::RV'))."\n";
	print "methods(B::PV) =\n\t".join("\n\t",methods('B::PV'))."\n";
	print "methods(B::MAGIC) =\n\t".join("\n\t",methods('B::MAGIC'))."\n";
	print "methods(B::SPECIAL) =\n\t".join("\n\t",methods('B::SPECIAL'))."\n";
}

sub methods
{
	my ($class) = @_;
	my %done;
	no strict qw(refs);
	my (@isa) = $class;
	my (@methods);
	while (@isa) {
		my $r = shift(@isa);
		next if $done{$r}++;
		my $s = \%{"${r}::"};
		for my $symname (keys %$s) {
			local *sym = *{$s->{$symname}};
			next unless defined &sym;
			next if $done{$symname}++;
			push(@methods, $symname);
		}
		push(@isa, @{"${r}::ISA"});
	}
	return (@methods);
}

print "# block at ".__LINE__."\n";

{
	tie my $x, 'ScalarInc';
	$x = 7;
	ok($x == 8);

	my %y;
	tie $y{z}, 'ScalarInc';
	$y{z} = 9;
	# print "y{z} = $y{z}\n";
	ok($y{z} == 10);

	my %a;
	my $b = \%a;
	tie $b->{z}, 'ScalarInc';
	$b->{z} = 11;
	ok($b->{z} == 12);
}


#
# Why does local($@) hide the active return?
# bug #29696
#

print "# block at ".__LINE__."\n";
{
	sub x9 {
		local($@);
		eval { &y9(); };
		TODO: {
			local $TODO = 'local($@) is hiding the exception return';
			ok($@ eq 'foo4:foo2');
		}
	}
	sub y9 {
		&z9();
	}
	sub z9 {
		local($@);
		my $x;
		eval { $x = 7 };
		eval { $x = 'foo2'; die "foo3\n" } || die "foo4:$x\n";
		die $@ if $@;
	}
	&x9();
}

print "# block at ".__LINE__."\n";
{
	sub a10 {
		local($@);
		die "foobar\n";
	}
	eval { &a10(); };
	TODO: {
		local $TODO = 'local($@) is hiding the exception return';
		ok($@ eq "foobar\n");
	}
}

print "# block at ".__LINE__."\n";
{
	sub a11 {
		local($@);
		eval { my $x };
		die "foobar2\n";
	}
	eval { &a11(); };
	TODO: {
		local $TODO = 'local($@) is hiding the exception return';
		ok($@ eq "foobar2\n");
	}
}

{
package ScalarInc;

sub TIESCALAR { my $pkg = shift; my $x; return bless \$x, $pkg };
sub FETCH { my $self = shift; return ++$$self; }
sub STORE { my $self = shift; my $o = $$self; $$self = shift; return $o; }
}



#
# Slice notation works for deleting hash elements
#

print "# block at ".__LINE__."\n";
{
	my %x = (
		a => 1,
		b => 2,
		c => 3,
		d => 4
	);
	delete @x{'a', 'd'};
	ok(! exists($x{a}));
	ok(exists($x{b}));
	ok(exists($x{c}));
	ok(! exists($x{d}));
}
print "# block at ".__LINE__."\n";
{
	my %x;
	tie %x, 'Hash1', {};
	%x = (
		a => 1,
		b => 2,
		c => 3,
		d => 4
	);
	delete @x{'a', 'd'};
	ok(! exists($x{a}));
	ok(exists($x{b}));
	ok(exists($x{c}));
	ok(! exists($x{d}));
}

package Hash1;

sub TIEHASH
{
	my $pkg = shift;
	return bless [ @_ ], $pkg;
}

sub FETCH
{
	my $self = shift;
	my $key = shift;
	my ($underlying) = @$self;
	return $underlying->{$key};
}

sub STORE
{
	my $self = shift;
	my $key = shift;
	my $value = shift;
	my ($underlying) = @$self;
	return ($underlying->{$key} = $value);
}

sub DELETE
{
	my ($self, $key) = @_;
	my ($underlying) = @$self;
	return delete($underlying->{$key});
}

sub CLEAR
{
	my $self = shift;
	my ($underlying) = @$self;
	%$underlying = ();
}

sub EXISTS
{
	my $self = shift;
	my $key = shift;
	my ($underlying) = @$self;
	return exists $underlying->{$key};
}

sub FIRSTKEY
{
	my $self = shift;
	my ($underlying) = @$self;
	keys %$underlying;
	return each %$underlying;
}

sub NEXTKEY
{
	my $self = shift;
	my ($underlying) = @$self;
	return each %$underlying;
}

1;
