The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# -*- perl -*-

# Attribute inheritance processing.

use strict;
use warnings;
use Test;
use Games::Object qw(ATTR_STATIC ATTR_NO_INHERIT FLAG_NO_INHERIT);
use Games::Object::Manager;

BEGIN { $| = 1; plan tests => 46 }

# Create two objects and parent one to the other.
my $man = Games::Object::Manager->new();
my $pobj = Games::Object->new(-id => "ParentObject");
ok( $pobj );
my $cobj = Games::Object->new(-id => "ChildObject");
ok( $cobj );
$man->add($pobj);
$man->add($cobj);
eval('$man->inherit($pobj, $cobj)');
ok( $@ eq '' );
print "# DEBUG: \$@ = $@" if ($@);
my $test = $man->inheriting_from($cobj);
ok( ref($test) eq 'Games::Object' && $test->id() eq $pobj->id() );

# Create some attributes and flags on the parent.
eval('$pobj->new_attr(
	-name	=> "FeelFree",
	-type	=> "int",
	-value	=> 10)');
ok( $@ eq '' );
eval('$pobj->new_flag(
	-name	=> "FlagFeelFree",
	-value	=> 1)');
ok( $@ eq '' );
print "# DEBUG: \$@ = $@" if ($@);
eval('$pobj->new_attr(
	-name	=> "CantTouchThis",
	-type	=> "int",
	-flags	=> ATTR_STATIC,
	-value	=> 20)');
ok( $@ eq '' );
print "# DEBUG: \$@ = $@" if ($@);
eval('$pobj->new_attr(
	-name	=> "MineMineMine",
	-type	=> "int",
	-flags	=> ATTR_NO_INHERIT,
	-value	=> 30)');
ok( $@ eq '' );
print "# DEBUG: \$@ = $@" if ($@);
eval('$pobj->new_attr(
	-name	=> "FlagMineMineMine",
	-flags	=> FLAG_NO_INHERIT,
	-value	=> 1)');
ok( $@ eq '' );
print "# DEBUG: \$@ = $@" if ($@);

# All but the last should appear to exist on the child.
ok( $cobj->attr_exists("FeelFree") );
ok( $cobj->attr_exists("CantTouchThis") );
ok( !$cobj->attr_exists("MineMineMine") );

# Should be able to see the first flag but not the second
ok( $cobj->is("FlagFeelFree") );
ok( !$cobj->is("FlagMineMineMine") );

# And they should report proper values from the child.
ok( $cobj->attr("FeelFree") == 10 );
ok( $cobj->attr("CantTouchThis") == 20 );
ok( !defined($cobj->attr("MineMineMine")) );

# And none should be shown to actually physically exist on the child.
ok( !$cobj->attr_exists_here("FeelFree") );
ok( !$cobj->attr_exists_here("CantTouchThis") );
ok( !$cobj->attr_exists_here("MineMineMine") );

# Clear flag on parent. Child should now report it cleared.
eval('$pobj->clear("FlagFeelFree")');
ok( $@ eq '' );
print "# DEBUG: \$@ = $@" if ($@);
ok( !$cobj->is("FlagFeelFree") );

# Put a modifier on one of the attributes for the parent and process it. We
# should see the new value from the child. It should still exist only
# "superficially" on the child.
eval('$pobj->mod_attr(
	-name	=> "FeelFree",
	-modify	=> 1,
	-incremental => 1,
	-persist_as => "FeelFreeMod")');
ok( $@ eq '' );
print "# DEBUG: \$@ = $@" if ($@);
$pobj->process();
ok( $cobj->attr("FeelFree") == 11 );
ok( $cobj->attr_exists("FeelFree") );
ok( !$cobj->attr_exists_here("FeelFree") );

# Modify the same attribute on the child. We should see the new value on the
# child and continue to see the old value on the parent. It should now REALLY
# exist on the child.
eval('$cobj->mod_attr(
	-name	=> "FeelFree",
	-modify	=> 5)');
ok( $@ eq '' );
print "# DEBUG: \$@ = $@" if ($@);
ok( $cobj->attr("FeelFree") == 16 );
ok( $pobj->attr("FeelFree") == 11 );
ok( $cobj->attr_exists("FeelFree") );
ok( $cobj->attr_exists_here("FeelFree") );

# Process the parent object. It should change, child attribute should not.
$pobj->process();
ok( $cobj->attr("FeelFree") == 16 );
ok( $pobj->attr("FeelFree") == 12 );

# Create a third object, make it the child of the child. It should see
# FeelFree from the child, CantTouchThis from the parent, and MineMineMine
# not at all.
my $gobj = Games::Object->new(-id => "GrandChildObject");
$man->add($gobj);
ok( $gobj );
eval('$man->inherit($cobj, $gobj)');
ok( $@ eq '' );
print "# DEBUG: \$@ = $@" if ($@);
ok( $gobj->attr("FeelFree") == 16 );
ok( $gobj->attr("CantTouchThis") == 20 );
ok( !defined($gobj->attr("MineMineMine")) );

# Delete the attribute from the child. We should again see the parent attribute.
eval('$cobj->del_attr("FeelFree")');
ok( $@ eq '' );
print "# DEBUG: \$@ = $@" if ($@);
ok( $cobj->attr("FeelFree") == 12 );
ok( $cobj->attr_exists("FeelFree") );
ok( !$cobj->attr_exists_here("FeelFree") );

# And the grandchild should see it too.
ok( $gobj->attr("FeelFree") == 12 );

# An attempt to set the static, inherited attribute should fail.
eval('$cobj->mod_attr(
	-name	=> "CantTouchThis",
	-modify	=> 5)');
ok( $@ =~ /attempt to modify static/i );
eval('$gobj->mod_attr(
	-name	=> "CantTouchThis",
	-modify	=> 5)');
ok( $@ =~ /attempt to modify static/i );

# Save this test for last, since if it fails, other tests may cause
# infinite loops. Make sure we can't incur a circular parent list.
eval('$man->inherit($gobj, $pobj)');
ok( $@ =~ /Relating ParentObject to GrandChildObject in manner inherit would create a circular relationship/i );