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';
    use base 'Class_B';

    sub init {
        my $obj = shift;
        my ( $one_A, $two_A, $one_B, $two_B) = @_;
        $obj = $obj->Class_A::init() unless ref $obj;
        $obj->Class_A::init( $one_A, $two_A);
        $obj->Class_B::init( $one_B, $two_B);
    }
}

### Basic class functionality, under thread if avalable
{
    my $ref = [];
    my ( $one_A, $two_A) = ( 'haha', $ref);
    my ( $one_B, $two_B) = ( 'hihi', $ref);

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

    is $cc->one_A, $one_A, "Class_C field 'one_A'";
    is $cc->two_A, $two_A, "Class_C field 'two_A'";
    is $cc->one_B, $one_B, "Class_C field 'one_B'";
    is $cc->two_B, $two_B, "Class_C field 'two_B'";

    SKIP: {
        use Config;
        skip "No thread support", 5 + 4 unless $Config{ usethreads};
        require threads;
        treads->import if threads->can( 'import');

        my $ans = threads->create(
            sub {
                {
                    one_A         => $cc->one_A,
                    two_A         => $cc->two_A,
                    one_B         => $cc->one_B,