cumulative.t   [plain text]

package Base1;
use Class::Std;
BEGIN{ @ISA = qw( Base2 ); }
{
    sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ }
    sub der_first  :CUMULATIVE             { return __PACKAGE__ }
    sub shift_obj  :CUMULATIVE             { return shift       }
}

package Base2;
use Class::Std;
{
    sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ }
    sub der_first  :CUMULATIVE             { return __PACKAGE__ }
    sub shift_obj  :CUMULATIVE             { return shift       }
}

package Base3;
use Class::Std;
use base qw( Base2 );
{
    sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ }
    sub der_first  :CUMULATIVE             { return __PACKAGE__ }
    sub shift_obj  :CUMULATIVE             { return shift       }
}

package Base4;
use Class::Std;
{
    sub base_first                         { return __PACKAGE__ }
    sub der_first                          { return __PACKAGE__ }
    sub shift_obj                          { return shift       }
}

package Der1;
use Class::Std;
use base qw(Base1 Base2 Base3 Base4);
{
    sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ }
    sub der_first  :CUMULATIVE             { return __PACKAGE__ }
    sub shift_obj  :CUMULATIVE             { return shift       }
}

package Der2;
use Class::Std;
use base qw(Base1 Base2 Base3 Base4);
{
    sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ }
    sub der_first  :CUMULATIVE             { return __PACKAGE__ }
    sub shift_obj  :CUMULATIVE             { return shift       }
}

package Reder1;
use Class::Std;
use base qw(Der1 Der2);
{
    sub base_first :CUMULATIVE(BASE FIRST) { return __PACKAGE__ }
    sub der_first  :CUMULATIVE             { return __PACKAGE__ }
    sub shift_obj  :CUMULATIVE             { return shift       }
}

package main;

use Test::More tests => 62;

my $obj = Reder1->new();

my @up_order   = qw( Reder1 Der1 Der2 Base1 Base3 Base2 );
my @down_order = qw( Base2 Base1 Base3 Der1 Der2 Reder1 );

my $up_string   = join q{}, @up_order;
my $down_string = join q{}, @down_order;

my @objs = ($obj) x 6;

for my $test_run (1..2) {
    my $res_up   = $obj->der_first();
    my $res_down = $obj->base_first();
    my $res_objs = $obj->shift_obj();

    is int $res_up,   int @up_order           => 'Numeric cumulative up';
    is int $res_down, int @down_order         => 'Numeric cumulative down';

    is "$res_up",   $up_string                => 'String cumulative up';
    is "$res_down", $down_string              => 'String cumulative down';

    is_deeply \@$res_up,   \@up_order         => 'List cumulative up';
    is_deeply \@$res_down, \@down_order       => 'List cumulative down';

    for my $classname (keys %$res_up) {
        ok grep($classname, @up_order)        => "Valid up hash key ($classname)";
        is $classname, $res_up->{$classname}  => "Valid up hash value ($classname)";
    }

    for my $classname (keys %$res_down) {
        ok grep($classname, @down_order)      => "Valid down hash key ($classname)";
        is $classname, $res_up->{$classname}  => "Valid down hash value ($classname)";
    }

    is_deeply \@$res_objs, \@objs             => "shift(\@_) used in method";
}