#!/usr/bin/perl -w
# $Id: 18storable.t 1511 2010-08-21 23:24:49Z ian $

# storable.t
#
# Ensure Class::Declare objects are serializable via Storable.

use strict;
use Test::More  tests => 23;
use Test::Exception;

# define a Class::Declare package
package Test::Storable::One;
use base qw( Class::Declare );

# declare some public attributes
__PACKAGE__->declare( public => { a => 1 , b => \2 } );

1;


# commence the tests
package main;

#
# Storable uses hooks within the defining class to perform custom
# serializations of objects: STORABLE_freeze() & STORABLE_thaw()
# To test whether these both work, we can atempt to deep clone the
# object, since this will involve initially a freeze and then a thaw.
#

use Storable  qw( dclone );

# create an instance of the Test::Storable object
my  $object = Test::Storable::One->new;

# create a clone of this object using Storable's dclone()
my  $clone;
lives_ok { $clone = dclone( $object ) } 'cloning lives';

# ensure that $clone is a reference and is a reference to a
# Test::Storable object
ok( ref( $clone ) , 'clone is a reference' );
ok( ref( $clone ) eq ref( $object ) , 'clone is an object' );

# ensure these represent two different objects
ok(    $object   !=    $clone   , 'cloned object is different from original' );
{ # ensure the scalar the clone references is different from the original
  no strict 'refs';
  ok( ${ $object } ne ${ $clone } ,
      'cloned object index is different from original' );
}

# ensure the public attributes have been cloned properly
#   - references should be cloned
#   - values should be copied
ok(    $object->a   ==    $clone->a               , 'scalar value cloned' );
ok(                  ref( $clone->b )             , 'reference copied' );
ok(                  ref( $clone->b ) eq 'SCALAR' , 'reference type cloned' );
ok(    $object->b   !=    $clone->b               , 'reference cloned' );
ok( ${ $object->b } == ${ $clone->b }             , 'reference value cloned' );


# Storable doesn't handle CODEREFs, so Class::Declare implements a little
# hack to allow dclone() to work with CODEREFs ... time to test it

package Test::Storable::Two;

use strict;
use base qw( Class::Declare );

# declare a public attribute with a CODEREF value
use constant  RANDOM  => rand;

__PACKAGE__->declare( public => { attribute => sub { RANDOM } } );

1;

# return to main to resume testing
package main;

# can we create the object?
lives_ok { $object = Test::Storable::Two->new }
         "object creation with code reference attribute succeeds";

# can we clone the object?
lives_ok { $clone  = dclone( $object ) }
         "cloning of object with code reference attribute value succeeds";

# is the original object still have a CODEREF as the attribute value?
ok( ref( $object->attribute ) eq 'CODE' ,
    "cloning preserves original attribute as code reference" );

# does the original CODEREF still return the right value?
ok( $object->attribute->() == Test::Storable::Two::RANDOM ,
    "original attribute preserves value after cloning" );

# does the cloned object have a CODEREF as the attribute value?
ok( ref( $clone->attribute ) eq 'CODE' ,
    "cloned attribute takes code reference value" );

# does this CODEREF return the correct value?
ok( $clone->attribute->() == Test::Storable::Two::RANDOM ,
    "cloned attribute preserves original value" );


# make sure Class::Declare handles two attributes assigned the same CODEREF
# properly (i.e. when cloned, they point to the same CODEREF)

package Test::Storable::Three;

use strict;
use base qw( Class::Declare );

use constant  RANDOM    => rand;
use constant  SUBROUTINE  => sub { RANDOM };

__PACKAGE__->declare( public => { a => SUBROUTINE ,
                                  b => SUBROUTINE } );

1;

# return to main to resume testing
package main;

  $object = Test::Storable::Three->new;

# make sure cloning survives with two attributes with CODEREF values
lives_ok { $clone = dclone( $object ) }
         "cloning of object with two code reference attribute values succeeds";

# make sur eboth attributes are the same
ok( $object->a ==  $clone-> a , "duplicate attribute code reference cloned" );
ok( $object->b ==  $clone-> b , "duplicate attribute code reference cloned" );
ok( $object->a == $object-> b , "duplicate attribute code reference cloned" );
ok(  $clone->a ==  $clone-> b , "duplicate attribute code reference cloned" );

# make sure they are still CODEREFs for the correct subroutine
ok( ref( $clone->a ) eq 'CODE' ,
    "cloning duplicate attribute preserves original code reference" );
ok( $clone->a->() eq Test::Storable::Three::RANDOM ,
    "cloning duplicate attribute preserves value" );