# -*- perl -*-

# Load and save capabilities

package GOTM;

use strict;
use warnings;
use Exporter;
use vars qw(@ISA @EXPORT);

@ISA = qw(Exporter);
@EXPORT = qw($RESULT);

my %index = ();

sub new
{
	my $class = shift;
	my $obj = {};
	%$obj = @_;
	$index{$obj->{id}} = $obj;
	bless $obj, $class;
	$obj;
}

sub find
{
	shift if @_ > 1;
	my $id = shift;

	$index{id};
}

sub id { shift->{id}; }

sub load
{
	my $class = shift;
	my $file = shift;
	my $obj = {};

	while (my $tag = <$file>) {
	    chomp $tag;
	    last if ($tag eq "ZOT");
	    my $val = <$file>;
	    chomp $val;
	    $obj->{$tag} = $val;
	}
	bless $obj, $class;
}

sub save
{
	my $obj = shift;
	my $file = shift;

	foreach my $tag (keys %$obj) {
	    print $file "$tag\n$obj->{$tag}\n";
	}
	print $file "ZOT\n";
	1;
}

1;

package GOTMSub;

use strict;
use warnings;
use Exporter;
use Games::Object;
use vars qw(@EXPORT_OK @ISA);

@ISA = qw(Games::Object Exporter);
@EXPORT_OK = qw(@RESULTS);

use vars qw(@RESULTS);

sub initialize { @RESULTS = (); }

sub new
{
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $obj = Games::Object->new(@_);

	bless $obj, $class;
	$obj;
}

# Test method just to make sure it REALLY got re-blessed properly ...

sub answer { 42; }

# Action callbacks, to prove that these can be reloaded.

sub action_changed1
{
	my ($self, $old, $new) = @_;
	push @RESULTS, [ $self->id(), 1, $old, $new ];
	1;
}

sub action_changed2
{
	my ($self, $change) = @_;
	push @RESULTS, [ $self->id(), 2, $change ];
	1;
}

sub action_maxed
{
	my ($self, $excess) = @_;
	push @RESULTS, [ $self->id(), 'max', $excess ];
	1;
}

1;

package main;

use strict;
use warnings;
use Test;
use Games::Object qw(:attrflags);
use Games::Object::Manager;
use IO::File;

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

# Create an object from the test module for later use.
my $testobj = GOTM->new(
    id	=> "ackthhbt",
    foo	=> 'blub',
    bar	=> 'blork',
    zog	=> 'yes, no',
);

# Create an object with some attributes.
my $filename = "./testobj.save";
my $obj1 = GOTMSub->new(-id => "SaveObject");
$obj1->new_attr(
    -name	=> "TheAnswer",
    -type	=> "int",
    -value	=> 42,
);
$obj1->new_attr(
    -name	=> "TheQuestion",
    -type	=> "string",
    -value	=> "Unknown, computation did not complete.",
);
$obj1->new_attr(
    -name	=> "HarrysHouse",
    -type	=> 'string',
    -values	=> [qw(Gryffindor Ravenclaw Hufflepuff Slytherin)],
    -value	=> 'Gryffindor',
);
$obj1->new_attr(
    -name	=> "EnterpriseCommander",
    -type	=> 'string',
    -values	=> [qw(Archer Kirk Picard)],
    -map	=> {
	Archer	=> "First starship named Enterprise",
	Kirk	=> "Constitution class vessel",
	Picard	=> "Galaxy class vessel",
    },
    -value	=> 'Kirk',
);
$obj1->new_attr(
    -name	=> "PercentDone",
    -type	=> 'number',
    -value	=> 0,
    -real_value	=> 100,
    -tend_to_rate => 0.5,
);
$obj1->new_attr(
    -name	=> "ComplexData",
    -type	=> 'any',
    -value	=> {
	foo	=> 'bar',
	baz	=> [ 'fud', 'bop' ],
	blork	=> {
	    this	=> 'that',
	    here	=> 'there',
	}
    },
);
$obj1->new_attr(
    -name	=> "ActionData",
    -type	=> 'int',
    -value	=> 50,
    -minimum	=> 0,
    -maximum	=> 100,
    -on_change	=> [
	[ 'O:self', 'action_changed1', 'A:old', 'A:new' ],
	[ 'O:self', 'action_changed2', 'A:change' ],
    ],
    -on_maximum	=> [ 'O:self', 'action_maxed', 'A:excess' ],
);
$obj1->new_attr(
    -name	=> "DisappearingData",
    -flags	=> ATTR_DONTSAVE,
    -type	=> "string",
    -value	=> "How not to be seen",
);
$obj1->new_attr(
    -name	=> "MagicalData",
    -flags	=> ATTR_AUTOCREATE | ATTR_DONTSAVE,
    -type	=> "string",
    -value	=> "Supercalifragilisticexpialadocious",
);

# Add an object reference.
eval('$obj1->new_attr(
    -name	=> "WeirdObject",
    -type	=> "object",
    -value	=> $testobj,
)');
ok( $@ eq '' );
print "# \$@ = $@" if ($@ ne '');

# Trigger the action callbacks on ActionData just to make sure they work.
GOTMSub->initialize();
$obj1->mod_attr(-name => "ActionData", -modify => 10);
ok( @GOTMSub::RESULTS == 2
 && $GOTMSub::RESULTS[0][0] eq 'SaveObject'
 && $GOTMSub::RESULTS[0][1] == 1
 && $GOTMSub::RESULTS[0][2] == 50
 && $GOTMSub::RESULTS[0][3] == 60
 && $GOTMSub::RESULTS[1][0] eq 'SaveObject'
 && $GOTMSub::RESULTS[1][1] == 2
 && $GOTMSub::RESULTS[1][2] == 10 );

# Save it to a file.
my $file1 = IO::File->new();
$file1->open(">$filename") or die "Cannot open file $filename\n";
eval('$obj1->save(-file => $file1)');
ok( $@ eq '' );
print "# \$@ = $@" if ($@ ne '');
$file1->close();
my $size = -s $filename;
#print "# $filename is $size bytes\n";
ok( $size != 0 );

# Now reopen this file and try to create a new object from it.
my $file2 = IO::File->new();
$file2->open("<$filename") or die "Cannot open file $filename\n";
my $obj2;
eval('$obj2 = Games::Object->load(-file => $file2)');
ok( defined($obj2) && $obj2->id() eq 'SaveObject');
print "# \$@ = $@" if (!defined($obj2));
$file2->close();

# Check that the attributes are the same. The pure DONTSAVE attribute should
# NOT be there, while the DONTSAVE + AUTOCREATE should be there but empty.
ok( $obj2->attr('TheAnswer') == 42 );
ok( $obj2->attr('TheQuestion') eq "Unknown, computation did not complete." );
ok( $obj2->attr('HarrysHouse') eq 'Gryffindor' );
ok( $obj2->attr('EnterpriseCommander') eq 'Constitution class vessel' );
ok( $obj2->raw_attr('EnterpriseCommander') eq 'Kirk' );
ok( $obj2->attr('PercentDone') == 0 );
my $data = $obj2->attr('ComplexData');
ok( $data->{foo} eq 'bar'
 && $data->{baz}[1] eq 'bop'
 && $data->{blork}{this} eq 'that' );
ok( $obj2->attr('ActionData') == 60 );
ok( !$obj2->attr_exists('DisappearingData') );
ok( $obj2->attr_exists('MagicalData') && $obj2->attr('MagicalData') eq '' );

# Check that the object reference was loaded and contains the right data.
# We cheat a little here in the interests of testing: we compare stringified
# references (to insure that a new object was indeed created and this is not
# just the old reference) and to check the values of the object's keys.
my $testobj2 = $obj2->attr('WeirdObject');
ok( "$testobj2" ne "$testobj" && ref($testobj2) eq 'GOTM' );
ok( $testobj2->{id} eq "ackthhbt"
 && $testobj2->{foo} eq 'blub'
 && $testobj2->{bar} eq 'blork'
 && $testobj2->{zog} eq 'yes, no' );

# Call process() on the second object. Make sure it updated but the new one
# did not, which should prove that they're distinct objects.
$obj2->process();
ok( $obj1->attr('PercentDone') == 0 );
ok( $obj2->attr('PercentDone') == 0.5 );

# Tweak the action callback as well, make sure it executes
GOTMSub->initialize();
$obj2->mod_attr(-name => "ActionData", -modify => 5);
ok( @GOTMSub::RESULTS == 2
 && $GOTMSub::RESULTS[0][0] eq 'SaveObject'
 && $GOTMSub::RESULTS[0][1] == 1
 && $GOTMSub::RESULTS[0][2] == 60
 && $GOTMSub::RESULTS[0][3] == 65
 && $GOTMSub::RESULTS[1][0] eq 'SaveObject'
 && $GOTMSub::RESULTS[1][1] == 2
 && $GOTMSub::RESULTS[1][2] == 5 );

# Now attempt to load that file by its filename rather than opening the file
# ourselves. We turn on the attribute accessor method feature to make sure
# that.
my $obj3;
eval('$obj3 = Games::Object->load(-filename =>$filename)');
ok( defined($obj3) && $obj3->id() eq 'SaveObject' );
ok( $obj3->attr('TheAnswer') == 42 );
ok( $obj3->attr('TheQuestion') eq "Unknown, computation did not complete." );
ok( $obj3->attr('HarrysHouse') eq 'Gryffindor' );
ok( $obj3->attr('EnterpriseCommander') eq 'Constitution class vessel' );
ok( $obj3->raw_attr('EnterpriseCommander') eq 'Kirk' );
ok( $obj3->attr('PercentDone') == 0 );
ok( $obj3->attr('ActionData') == 60 );
my $testobj3 = $obj3->attr('WeirdObject');
ok( "$testobj3" ne "$testobj" && ref($testobj3) eq 'GOTM' );
ok( $testobj3->{id} eq "ackthhbt"
 && $testobj3->{foo} eq 'blub'
 && $testobj3->{bar} eq 'blork'
 && $testobj3->{zog} eq 'yes, no' );

# Tweak the action callback as well, make sure it executes
GOTMSub->initialize();
$obj3->mod_attr(-name => "ActionData", -modify => 5);
ok( @GOTMSub::RESULTS == 2
 && $GOTMSub::RESULTS[0][0] eq 'SaveObject'
 && $GOTMSub::RESULTS[0][1] == 1
 && $GOTMSub::RESULTS[0][2] == 60
 && $GOTMSub::RESULTS[0][3] == 65
 && $GOTMSub::RESULTS[1][0] eq 'SaveObject'
 && $GOTMSub::RESULTS[1][1] == 2
 && $GOTMSub::RESULTS[1][2] == 5 );

# Finally, we need to test the ability to load multiple objects from the
# same file. Note that we're testing exclusively the individual object load/save
# functionality rather than manager functionality, which is covered in another
# test. First produce a file containing several objects in it.
unlink $filename;
$filename = "./testobjs.save";
my $file3 = IO::File->new();
$file3->open(">$filename") or die "Cannot open file $filename\n";
my $count = 0;
my @pspecs = (
    [ 'Mercury', 'Mercurial Mugwumps', 1.3 ],
    [ 'Venus', 'Venusian Voles', 2.9 ],
    [ 'Earth', 'Hectic Humans', 1.4 ],
    [ 'Mars', 'Martian Mammals', 12.7 ],
    [ 'Jupiter', 'Jovian Jehosephats', 5.9 ],
    [ 'Saturn', 'Saturine Satyrs', 0.6 ],
    [ 'Uranus', 'Uranian Ugnaughts', 0.9 ],
    [ 'Neptune', 'Neptunian Nymphs', 1.5 ],
    [ 'Pluto', 'Plutonian Plutocrats', 0.00005 ],
);
foreach my $spec (@pspecs) {
	$count++;
	my $obj = Games::Object->new(-id => 'Planet' . $count);
	$obj->new_attr(
	    -name	=> 'Name',
	    -type	=> 'string',
	    -value	=> $spec->[0],
	);
	$obj->new_attr(
	    -name	=> "Lifeform",
	    -type	=> 'string',
	    -value	=> $spec->[1],
	);
	$obj->new_attr(
	    -name	=> "GalacticCreditExchangeRate",
	    -type	=> 'number',
	    -value	=> $spec->[2],
	);
	$obj->save(-file => $file3);
}
$file3->close();
$size = -s $filename;
#print "# $filename is $size bytes\n";

# Now reopen the file and attempt to read them back in, validating as we go.
my $file4 = IO::File->new();
$file4->open("<$filename") or die "Cannot open file $filename\n";
while ($count) {
    my $spec = shift @pspecs;
    my $obj;
    my $pnum = 10 - $count;
    eval('$obj = Games::Object->load(-file =>$file4, -id => "NewPlanet" . $pnum)');
    if ($@) {
	print "# Load of $pnum failed\n";
	last;
    }
    if ($obj->attr('Name') ne $spec->[0]) {
	print "# attr Name is bad in $pnum\n";
	last;
    }
    if ($obj->attr('Lifeform') ne $spec->[1]) {
	print "# attr Lifeform is bad in $pnum\n";
	last;
    }
    if ($obj->attr('GalacticCreditExchangeRate') != $spec->[2]) {
	print "# attr GalacticCreditExchangeRate is bad in $pnum\n";
	last;
    }
    $count --;
}
$file4->close();
ok( $count == 0 );
unlink $filename;

exit (0);