The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl -w

use strict;

use Class::ClassDecorator;

use Test::More tests => 27;

{
    package Foo::Base;

    sub new { bless {}, shift }

    sub foo { 'base' }
}

{
    package Foo::Bar;

    sub foo { 'bar' }

    sub bar { 'also bar' }

    sub other { 'in bar' }
}

{
    package Foo::Baz;

    sub baz { 'baz' }

    sub other { 'in baz' }
}

{
    my $class = Class::ClassDecorator::hierarchy( 'Foo::Base', 'Foo::Bar', 'Foo::Baz' );

    my $object = $class->new;

    foreach my $c ( qw( Foo::Base Foo::Bar Foo::Baz ) )
    {
        isa_ok( $object, $c );
    }

    foreach my $m ( qw( foo bar baz other ) )
    {
        can_ok( $object, $m );
    }

    is( $object->foo,   'bar' );
    is( $object->bar,   'also bar' );
    is( $object->baz,   'baz' );
    is( $object->other, 'in baz' );
}

{
    my $class = Class::ClassDecorator::hierarchy( 'Foo::Base', 'Foo::Baz', 'Foo::Bar' );

    my $object = $class->new;

    foreach my $c ( qw( Foo::Base Foo::Bar Foo::Baz ) )
    {
        isa_ok( $object, $c );
    }

    foreach my $m ( qw( foo bar baz other ) )
    {
        can_ok( $object, $m );
    }

    is( $object->foo,   'bar' );
    is( $object->bar,   'also bar' );
    is( $object->baz,   'baz' );
    is( $object->other, 'in bar' );
}

{
    package Super::Base;

    sub new { bless {}, shift }

    sub meth { 'base' }
}

{
    package Super::Foo;

    sub new { bless {}, shift }

    sub meth { join ' ', 'foo', shift->super::meth() }
}

{
    package Super::Bar;

    sub new { bless {}, shift }

    sub meth { join ' ', 'bar', shift->super::meth() }
}

{
    my $class = Class::ClassDecorator::hierarchy( 'Super::Base', 'Super::Foo', 'Super::Bar' );

    is( $class->meth, 'bar foo base' );
}

{
    my $class = Class::ClassDecorator::hierarchy( 'Super::Base', 'Super::Bar', 'Super::Foo' );

    is( $class->meth, 'foo bar base' );
}

{
    package Super::NoMeth;

    sub new { bless {}, shift }
}

{
    package Super::HasMeth;

    sub new { bless {}, shift }

    sub meth { join ' ', 'has', shift->super::meth() }
}

{
    my $class =
        Class::ClassDecorator::hierarchy( 'Super::Base', 'Super::NoMeth', 'Super::HasMeth' );

    is( $class->meth, 'has base' );
}

{
    my $class =
        Class::ClassDecorator::hierarchy( 'Super::Base', 'Super::HasMeth', 'Super::NoMeth' );

    is( $class->meth, 'has base' );
}

{
    my $class1 =
        Class::ClassDecorator::hierarchy( 'Super::Base', 'Super::NoMeth', 'Super::HasMeth' );

    my $class2 =
        Class::ClassDecorator::hierarchy( 'Super::Base', 'Super::NoMeth', 'Super::HasMeth' );

    is( $class1, $class2, 'generated classes are cached' );
}