view release on metacpan or  search on metacpan

t/050-non-mop-integration/003-attributes-in-non-mop-inherited-class.t  view on Meta::CPAN

#!perl

use strict;
use warnings;

use Test::More;

{
    package My::Component;
    BEGIN { $INC{'My/Component.pm'} = __FILE__ }
    use strict;
    use warnings;

    sub new {
        my $class = shift;
        bless { @_ } => $class;
    }
}

{
    package App;
    use Moxie
        traits => [':experimental'];

    extends 'Moxie::Object', 'My::Component';

    has _foo => ();
    has _bar => sub { "BAR" };

    my sub _foo : private;

    sub bar : ro(_bar);

    sub REPR {
        my ($class, $proto) = @_;
        $class->My::Component::new( %$proto );
    }

    sub BUILD ($self, $params) {
        _foo = $params->{'foo'};
    }

    sub call { "HELLO " . _foo }
}

my $app = App->new( foo => 'WORLD' );
isa_ok($app, 'App');
isa_ok($app, 'My::Component');

is($app->call, 'HELLO WORLD', '... got the value we expected');
is($app->bar, 'BAR');

{
    package My::DBI;
    BEGIN { $INC{'My/DBI.pm'} = __FILE__ }
    use strict;
    use warnings;

    sub connect {
        my $class = shift;
        my ($dsn) = @_;
        bless { dsn => $dsn } => $class;
    }

    sub dsn { shift->{dsn} }
}

{
    package My::DBI::MOP;
    use Moxie
        traits => [':experimental'];

    extends 'Moxie::Object', 'My::DBI';

    has _foo => ();
    has _bar => sub { "BAR" };

    my sub _foo : private;

    sub bar : ro(_bar);

    sub connect { (shift)->new( dsn => @_ ) }

    sub REPR {
        my ($class, $proto) = @_;
        $class->My::DBI::connect( $proto->{dsn} );
    }

    sub BUILD ($self, $params) {
        _foo = 'WORLD';
    }

    sub call { "HELLO " . _foo }
}

my $dbh = My::DBI::MOP->connect('dbi:hash');
isa_ok($dbh, 'My::DBI::MOP');
isa_ok($dbh, 'My::DBI');

is($dbh->call, 'HELLO WORLD', '... got the value we expected');
is($dbh->bar, 'BAR');
is($dbh->dsn, 'dbi:hash');

done_testing;