view release on metacpan or  search on metacpan

t/03_class.t  view on Meta::CPAN

use warnings; use strict;
use Test::More;
my $n_tests;

# Class_A is a conventional hash-based class with two fields one_A and two_A
# Class_B is an Alter-based class with fields of one_B and two_B stored in an
# array.
# Both classes have an init() method that works as a creator when called
# as a class method. There are read-only accessors to the fields

# Class_C is a hybrid class inheriting both Class_A and Class_B
# For tests we set fields one_A and one_B to plain scalars.  two_A
# and two_B are set to hold a reference to the same array.  This identity
# must survive a freeze-thaw cycle by either Data::Dumper or Storable

### Class_A

{
    package Class_A;

    sub init {
        my $obj = shift;
        $obj = bless {}, $obj unless ref $obj;
        $obj->{ one_A} = shift;
        $obj->{ two_A} = shift;
        $obj;
    }

    sub one_A { $_[ 0]->{ one_A} }
    sub two_A { $_[ 0]->{ two_A} }
}

{
    my ( $one, $two) = ( 'haha', []);
    my $ca = Class_A->init( $one, $two);

    is $ca->one_A, $one, "Class_A field 'one_A'";
    is $ca->two_A, $two, "Class_A field 'two_A'";

    BEGIN { $n_tests += 2 }
}

### Class_B
{
    package Class_B;
    use Alter ego => [];

    sub init {
        my $obj = shift;
        $obj = bless \ my( $o), $obj unless ref $obj;
        my $ego = ego( $obj);
        $ego->[ 0] = shift;
        $ego->[ 1] = shift;
        $obj;
    }

    sub one_B { ego( $_[ 0])->[ 0] }
    sub two_B { ego( $_[ 0])->[ 1] }
}

{
    my ( $one, $two) = ( 'haha', []);
    my $cb = Class_B->init( $one, $two);

    is $cb->one_B, $one, "Class_B field 'one_B'";
    is $cb->two_B, $two, "Class_B field 'two_B'";

    BEGIN { $n_tests += 2 }
}

### Class_C
{
    package Class_C;
    use base 'Class_A';

t/03_class.t  view on Meta::CPAN

    my $cc = Class_C->init( $one_A, $two_A, $one_B, $two_B);
    $Alter::Storable::attaching = 0;
    $Alter::Storable::thawing   = 0;
    my $clone = Storable::thaw( Storable::freeze( $cc));

    my $attach_ok;
    if ( $Storable::VERSION < HAS_ATTACH ) {
        # Storable only recogizese STORABLE_thaw
        ok $Alter::Storable::thawing,    "STORABLE_thaw being used";
        ok !$Alter::Storable::attaching, "STORABLE_attach not used";
        $attach_ok = $Alter::Storable::thawing && !$Alter::Storable::attaching;
    } else {
        # Storable knows about STORABLE_attach
        ok $Alter::Storable::attaching, "STORABLE_attach being used";
        ok !$Alter::Storable::thawing, "STORABLE_thaw not used";
        $attach_ok = !$Alter::Storable::thawing && $Alter::Storable::attaching;
    }
    diag "Storable $Storable::VERSION" unless $attach_ok;

    is $clone->one_A, $one_A, "Cloned one_A (attach)";
    is $clone->one_B, $one_B, "Cloned one_B (attach)";
    isnt $clone->two_A, $two_A, "Cloned ref different (attach)";
    is ref $clone->two_A, 'ARRAY', "Cloned ref type (attach)";
    is $clone->two_B, $clone->two_A, "Cloned ref identity (attach)";

    BEGIN { $n_tests += 7 }
}

### Storable with STORABLE_thaw
{   # reconfig Class_B to use STORABLE_thaw
    package Class_B;
    use Alter qw(STORABLE_thaw STORABLE_freeze);
    our @ISA;
    @ISA = grep !/Storable/ => @ISA; # this makes the difference
}

{
    use Storable;

    my ( $one_A, $two_A) = ( 'haha', []);
    my ( $one_B, $two_B) = ( 'hihi', $two_A);

    my $cc = Class_C->init( $one_A, $two_A, $one_B, $two_B);
    $Alter::Storable::attaching = 0;
    $Alter::Storable::thawing   = 0;
    my $clone = Storable::thaw( Storable::freeze( $cc));

    ok $Alter::Storable::thawing,   "STORABLE_thaw being used";
    ok !$Alter::Storable::attaching, "STORABLE_attach not used";
    is $clone->one_A, $one_A, "Cloned one_A (thaw)";
    is $clone->one_B, $one_B, "Cloned one_B (thaw)";
    isnt $clone->two_A, $two_A, "Cloned ref different (thaw)";
    is ref $clone->two_A, 'ARRAY', "Cloned ref type (thaw)";
    is $clone->two_B, $clone->two_A, "Cloned ref identity (thaw)";

    BEGIN { $n_tests += 7 }
}

### Dumper
{
    use Data::Dumper;

    my ( $one_A, $two_A) = ( 'haha', []);
    my ( $one_B, $two_B) = ( 'hihi', $two_A);

    my $cc = Class_C->init( $one_A, $two_A, $one_B, $two_B);
    my $dump = $cc->Dumper;

#   diag $dump;
    my $image = do {
        my $VAR1;
        eval $dump;
        $VAR1;
    };
    diag "$@" if $@;

    my $body = $image->{ Alter::BODY()};
    my $soul = $image->{ Class_B};
    isa_ok $body, 'Class_C', "Dumper body";
    is ref $soul, "ARRAY", "Dumper soul is hash";
    is $body->{ one_A}, $one_A, "Dumper one_A";
    is $soul->[ 0], $one_B, "Dumper one_B";
    isnt $body->{ two_A}, $two_A, "Dumper evaled ref different";
    is ref $body->{ two_A}, 'ARRAY', "Dumper two_A is array";
    is $soul->[ 1], $body->{ two_A}, "Dumper ref identity";
    BEGIN { $n_tests += 7 }
}

BEGIN { plan tests => $n_tests }