view release on metacpan or  search on metacpan

t/11_storable_refs.t  view on Meta::CPAN

use strict;
use lib ".";

BEGIN {
    # don't run without Scalar::Util::weaken()
    eval "use Scalar::Util 'weaken'";
    if( $@ =~ /\AWeak references are not implemented/ ) {
        require Test::More;
        Test::More::plan( skip_all =>
            "Can't test storable refs without Scalar::Util::weaken" );
    }
}

use Test::More;
use Class::InsideOut ();
use Scalar::Util qw( refaddr reftype weaken isweak );

# Need Storable 2.04 ( relatively safe STORABLE_freeze support )
eval { require Storable and Storable->VERSION( 2.04 ) };
if ( $@ ) {
    plan skip_all => "Storable >= 2.04 not installed",
}

sub check_version {
    my ($class, $version) = @_;
    eval { require $class and $class->VERSION($version) };
    return $@ eq q{} ? 0 : 1;
}
    
my @serializers = (
    {
        class   => "Storable",
        version => 3.04,
        freeze  => sub { Storable::freeze( shift ) },
        thaw    => sub { Storable::thaw( shift ) },
    },
);

my $tests_per_serializer = 68;
plan tests => @serializers * $tests_per_serializer;

my $class = "t::Object::Friends";

for my $s ( @serializers ) {

    SKIP:
    {
        skip "$s->{class} $s->{version} required", $tests_per_serializer
            unless check_version( $s->{class}, $s->{version} );

        require_ok( $s->{class} );

        # Setup test data and variables

        my ($alice, $bob, $charlie);
        my ($alice2, $bob2, $charlie2);
        my ( $frozen, $thawed );
        my @friends;

        # start tests

        require_ok( $class );

        # create the objects
        ok( $alice = $class->new( { name => "Alice" } ),  
            "Creating $class object 'Alice'"
        );

        ok( $bob = $class->new( { name => "Bob" } ),  
            "Creating $class object 'Bob'"
        );

        ok( $bob->friends( $alice ),
            "Making Bob friends with Alice"
        );

t/11_storable_refs.t  view on Meta::CPAN

        );


        # check name
        is( $charlie2->name(), "Charlie",
            "... One thawed object is also named Charlie (hereafter Charlie2)"
        );

        isnt( refaddr $charlie2, refaddr $charlie,
            "... Charlie2 is not Charlie"
        );

        is( $bob2->name(), "Bob",
            "... Another thawed object is also named Bob (hereafter Bob2)"
        );

        isnt( refaddr $bob2, refaddr $bob,
            "... Bob2 is not Bob"
        );

        is( $alice2->name(), "Alice",
            "... Another thawed object is named Alice (hereafter Alice2)"
        );

        isnt( refaddr $alice2, refaddr $alice,
            "... Alice2 is not Alice"
        );

        # check reference copy
        ok( ! $bob2->has_friend( $alice ),
            "... Bob2 is not friends with Alice"
        );

        ok( ! $charlie2->has_friend( $alice ),
            "... Charlie2 is not friends with Alice"
        );

        ok( ! $charlie2->has_friend( $bob ),
            "... Charlie2 is not friends with Bob"
        );

        is( @friends = $charlie2->friends, 2,
            "... Charlie2 still has 2 friends"
        );

        ok( $charlie2->has_friend( $alice2 ),
            "... Charlie2 has Alice2 as a friend"
        );

        ok( $charlie2->has_friend( $bob2 ),
            "... Charlie2 has Bob2 as a friend"
        );

        ok( $bob2->has_friend( $alice2 ),
            "... Bob2 has Alice2 as a friend"
        );

        # storing Alice inside herself !!

        push @$alice, $alice;
        weaken( $alice->[0] );
        ok( isweak( $alice->[0] ),
            "Storing a weak reference to Alice inside Alice (!!)"
        );

        # freeze object
        ok( $frozen = $s->{freeze}->( $alice ),
            "Freezing Alice"
        );

        # thaw object
        ok( $alice2 = $s->{thaw}( $frozen ),
            "... Thawing the frozen Alice as Alice2"
        );

        is( ref $alice2, $class,
            "... Thawed Alice is a $class"
        );

        is( $alice2->[0], $alice2,
            "... Found Alice2 inside Alice2 (Lewis Carroll eat your heart out!)"
        );

        ok( ! isweak( $alice2->[0] ),
            "... Reference to Alice2 isn't weak -- limitation of Storable"
        );

        shift @$alice;
        is( @$alice, 0,
            "Removing Alice from herself"
        );

            
        # let's make alice a narcissist and clone her!

        ok( $alice->friends( $alice ),
            "Making Alice friends with herself (!!)"
        );

        # freeze object
        ok( $alice2 = $s->{thaw}->( $s->{freeze}->( $alice ) ),
            "Cloning Alice into Alice2 (with dclone)"
        );

        is( ref $alice2, $class,
            "... Thawed Alice is a $class"
        );

        isnt( refaddr $alice2, refaddr $alice,
            "... Alice2 is a new object"
        );

        # check reference copy
        ok( ! $alice2->has_friend( $alice ),
            "... Alice2 is not friends with Alice"
        );

        ok( $alice2->has_friend( $alice2 ),
            "... Alice2 is friends with Alice2"
        );