Implement strict constructors, which will warn unkown constructor arguments

[gitmo/Mouse.git] / t / 001_mouse / 047-attribute-metaclass-role.t

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 7;
use lib 't/lib';

do {
    package MouseX::AttributeHelpers::Number;
    use Mouse;
    extends 'Mouse::Meta::Attribute';

    has provides => (
        is => 'rw',
        isa => 'HashRef',
    );

    after 'install_accessors' => sub{
        my ($attr) = @_;

        my %provides = %{$attr->{provides}};
        my $method_constructors = {
            add => sub {
                my ($attr, $name) = @_;
                return sub {
                    $_[0]->$name( $_[0]->$name() + $_[1])
                };
            },
        };
        while (my ($name, $aliased) = each %provides) {
            $attr->associated_class->add_method(
                $aliased => $method_constructors->{$name}->($attr, $attr->name)
            );
        }
        return $attr;
    };

    package
        Mouse::Meta::Attribute::Custom::MyNumber;
    sub register_implementation { 'MouseX::AttributeHelpers::Number' }

    1;
    
    package Foo;
    use Mouse::Role;

    has 'i' => (
        metaclass => 'MyNumber',
        is => 'rw',
        isa => 'Int',
        provides => {
            'add' => 'add_number'
        },
    );
    sub f_m {}

    package Bar;
    use Mouse::Role;

    has 'j' => (
        metaclass => 'MyNumber',
        is => 'rw',
        isa => 'Int',
        provides => {
            'add' => 'add_number_j'
        },
    );
    sub b_m {}

    package Klass1;
    use Mouse;
    with 'Foo';

    package Klass2;
    use Mouse;
    with 'Foo', 'Bar';

};

{
    # normal
    can_ok 'Klass1', 'add_number';
    my $k = Klass1->new(i=>3);
    $k->add_number(4);
    is $k->i, 7;
}

{
    # combine
    can_ok 'Klass2', 'f_m';
    can_ok 'Klass2', 'b_m';
    can_ok 'Klass2', 'add_number';
    can_ok 'Klass2', 'add_number_j';
    my $k = Klass2->new(i=>3);
    $k->add_number(4);
    is $k->i, 7;
}