[gitmo/Mouse.git] / t / 050_metaclasses / 015_metarole.t

#!/usr/bin/perl

use strict;
use warnings;

use lib 't/lib', 'lib';

use Test::More tests => 91;
use Test::Exception;

use Mouse::Util::MetaRole;


{
    package My::Meta::Class;
    use Mouse;
    extends 'Mouse::Meta::Class';
}

{
    package Role::Foo;
    use Mouse::Role;
    has 'foo' => ( is => 'ro', default => 10 );
}

{
    package My::Class;

    use Mouse;
}

{
    package My::Role;
    use Mouse::Role;
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class       => My::Class->meta,
        metaclass_roles => ['Role::Foo'],
    );

    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
        'apply Role::Foo to My::Class->meta()' );
    is( My::Class->meta()->foo(), 10,
        '... and call foo() on that meta object' );
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class                 => 'My::Class',
        attribute_metaclass_roles => ['Role::Foo'],
    );

    ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
        q{apply Role::Foo to My::Class->meta()'s attribute metaclass} );
    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
        '... My::Class->meta() still does Role::Foo' );

    My::Class->meta()->add_attribute( 'size', is => 'ro' );
    is( My::Class->meta()->get_attribute('size')->foo(), 10,
        '... call foo() on an attribute metaclass object' );
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class              => 'My::Class',
        method_metaclass_roles => ['Role::Foo'],
    );

    ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
        q{apply Role::Foo to My::Class->meta()'s method metaclass} );
    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
        '... My::Class->meta() still does Role::Foo' );
    ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
        q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );

    My::Class->meta()->add_method( 'bar' => sub { 'bar' } );
    is( My::Class->meta()->get_method('bar')->foo(), 10,
        '... call foo() on a method metaclass object' );
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class                      => 'My::Class',
        wrapped_method_metaclass_roles => ['Role::Foo'],
    );

    ok( My::Class->meta()->wrapped_method_metaclass()->meta()->does_role('Role::Foo'),
        q{apply Role::Foo to My::Class->meta()'s wrapped method metaclass} );
    ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
        '... My::Class->meta() still does Role::Foo' );
    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
        '... My::Class->meta() still does Role::Foo' );
    ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
        q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );

    My::Class->meta()->add_after_method_modifier( 'bar' => sub { 'bar' } );
    is( My::Class->meta()->get_method('bar')->foo(), 10,
        '... call foo() on a wrapped method metaclass object' );
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class              => 'My::Class',
        instance_metaclass_roles => ['Role::Foo'],
    );

    ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
        q{apply Role::Foo to My::Class->meta()'s instance metaclass} );
    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
        '... My::Class->meta() still does Role::Foo' );
    ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
        q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
    ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
        q{... My::Class->meta()'s method metaclass still does Role::Foo} );

    is( My::Class->meta()->get_meta_instance()->foo(), 10,
        '... call foo() on an instance metaclass object' );
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class               => 'My::Class',
        constructor_class_roles => ['Role::Foo'],
    );

    ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
        q{apply Role::Foo to My::Class->meta()'s constructor class} );
    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
        '... My::Class->meta() still does Role::Foo' );
    ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
        q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
    ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
        q{... My::Class->meta()'s method metaclass still does Role::Foo} );
    ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
        q{... My::Class->meta()'s instance metaclass still does Role::Foo} );

    # Actually instantiating the constructor class is too freaking hard!
    ok( My::Class->meta()->constructor_class()->can('foo'),
        '... constructor class has a foo method' );
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class              => 'My::Class',
        destructor_class_roles => ['Role::Foo'],
    );

    ok( My::Class->meta()->destructor_class()->meta()->does_role('Role::Foo'),
        q{apply Role::Foo to My::Class->meta()'s destructor class} );
    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
        '... My::Class->meta() still does Role::Foo' );
    ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
        q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
    ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
        q{... My::Class->meta()'s method metaclass still does Role::Foo} );
    ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
        q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
    ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
        q{... My::Class->meta()'s constructor class still does Role::Foo} );

    # same problem as the constructor class
    ok( My::Class->meta()->destructor_class()->can('foo'),
        '... destructor class has a foo method' );
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class                        => 'My::Role',
        application_to_class_class_roles => ['Role::Foo'],
    );

    ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'),
        q{apply Role::Foo to My::Role->meta's application_to_class class} );

    is( My::Role->meta->application_to_class_class->new->foo, 10,
        q{... call foo() on an application_to_class instance} );
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class                        => 'My::Role',
        application_to_role_class_roles => ['Role::Foo'],
    );

    ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'),
        q{apply Role::Foo to My::Role->meta's application_to_role class} );
    ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'),
        q{... My::Role->meta's application_to_class class still does Role::Foo} );

    is( My::Role->meta->application_to_role_class->new->foo, 10,
        q{... call foo() on an application_to_role instance} );
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class                           => 'My::Role',
        application_to_instance_class_roles => ['Role::Foo'],
    );

    ok( My::Role->meta->application_to_instance_class->meta->does_role('Role::Foo'),
        q{apply Role::Foo to My::Role->meta's application_to_instance class} );
    ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'),
        q{... My::Role->meta's application_to_role class still does Role::Foo} );
    ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'),
        q{... My::Role->meta's application_to_class class still does Role::Foo} );

    is( My::Role->meta->application_to_instance_class->new->foo, 10,
        q{... call foo() on an application_to_instance instance} );
}

{
    Mouse::Util::MetaRole::apply_base_class_roles(
        for_class => 'My::Class',
        roles     => ['Role::Foo'],
    );

    ok( My::Class->meta()->does_role('Role::Foo'),
        'apply Role::Foo to My::Class base class' );
    is( My::Class->new()->foo(), 10,
        '... call foo() on a My::Class object' );
}

{
    package My::Class2;

    use Mouse;
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class                 => 'My::Class2',
        metaclass_roles           => ['Role::Foo'],
        attribute_metaclass_roles => ['Role::Foo'],
        method_metaclass_roles    => ['Role::Foo'],
        instance_metaclass_roles  => ['Role::Foo'],
        constructor_class_roles   => ['Role::Foo'],
        destructor_class_roles    => ['Role::Foo'],
    );

    ok( My::Class2->meta()->meta()->does_role('Role::Foo'),
        'apply Role::Foo to My::Class2->meta()' );
    is( My::Class2->meta()->foo(), 10,
        '... and call foo() on that meta object' );
    ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
        q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} );
    My::Class2->meta()->add_attribute( 'size', is => 'ro' );

    is( My::Class2->meta()->get_attribute('size')->foo(), 10,
        '... call foo() on an attribute metaclass object' );

    ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
        q{apply Role::Foo to My::Class2->meta()'s method metaclass} );

    My::Class2->meta()->add_method( 'bar' => sub { 'bar' } );
    is( My::Class2->meta()->get_method('bar')->foo(), 10,
        '... call foo() on a method metaclass object' );

    ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
        q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
    is( My::Class2->meta()->get_meta_instance()->foo(), 10,
        '... call foo() on an instance metaclass object' );

    ok( My::Class2->meta()->constructor_class()->meta()->does_role('Role::Foo'),
        q{apply Role::Foo to My::Class2->meta()'s constructor class} );
    ok( My::Class2->meta()->constructor_class()->can('foo'),
        '... constructor class has a foo method' );

    ok( My::Class2->meta()->destructor_class()->meta()->does_role('Role::Foo'),
        q{apply Role::Foo to My::Class2->meta()'s destructor class} );
    ok( My::Class2->meta()->destructor_class()->can('foo'),
        '... destructor class has a foo method' );
}


{
    package My::Meta;

    use Mouse::Exporter;
    Mouse::Exporter->setup_import_methods( also => 'Mouse' );

    sub init_meta {
        shift;
        my %p = @_;

        Mouse->init_meta( %p, metaclass => 'My::Meta::Class' );
    }
}

{
    package My::Class3;

    My::Meta->import();
}


{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class                 => 'My::Class3',
        metaclass_roles           => ['Role::Foo'],
    );

    ok( My::Class3->meta()->meta()->does_role('Role::Foo'),
        'apply Role::Foo to My::Class3->meta()' );
    is( My::Class3->meta()->foo(), 10,
        '... and call foo() on that meta object' );
    ok( ( grep { $_ eq 'My::Meta::Class' } My::Class3->meta()->meta()->superclasses() ),
        'apply_metaclass_roles() does not interfere with metaclass set via Mouse->init_meta()' );
}

{
    package Role::Bar;
    use Mouse::Role;
    has 'bar' => ( is => 'ro', default => 200 );
}

{
    package My::Class4;
    use Mouse;
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class                 => 'My::Class4',
        metaclass_roles           => ['Role::Foo'],
    );

    ok( My::Class4->meta()->meta()->does_role('Role::Foo'),
        'apply Role::Foo to My::Class4->meta()' );

    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class                 => 'My::Class4',
        metaclass_roles           => ['Role::Bar'],
    );

    ok( My::Class4->meta()->meta()->does_role('Role::Bar'),
        'apply Role::Bar to My::Class4->meta()' );
    ok( My::Class4->meta()->meta()->does_role('Role::Foo'),
        '... and My::Class4->meta() still does Role::Foo' );
}

{
    package My::Class5;
    use Mouse;

    extends 'My::Class';
}

{
    ok( My::Class5->meta()->meta()->does_role('Role::Foo'),
        q{My::Class5->meta()'s does Role::Foo because it extends My::Class} );
    ok( My::Class5->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
        q{My::Class5->meta()'s attribute metaclass also does Role::Foo} );
    ok( My::Class5->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
        q{My::Class5->meta()'s method metaclass also does Role::Foo} );
    ok( My::Class5->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
        q{My::Class5->meta()'s instance metaclass also does Role::Foo} );
    ok( My::Class5->meta()->constructor_class()->meta()->does_role('Role::Foo'),
        q{My::Class5->meta()'s constructor class also does Role::Foo} );
    ok( My::Class5->meta()->destructor_class()->meta()->does_role('Role::Foo'),
        q{My::Class5->meta()'s destructor class also does Role::Foo} );
}

{
    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class       => 'My::Class5',
        metaclass_roles => ['Role::Bar'],
    );

    ok( My::Class5->meta()->meta()->does_role('Role::Bar'),
        q{apply Role::Bar My::Class5->meta()} );
    ok( My::Class5->meta()->meta()->does_role('Role::Foo'),
        q{... and My::Class5->meta() still does Role::Foo} );
}

{
    package My::Class6;
    use Mouse;

    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class       => 'My::Class6',
        metaclass_roles => ['Role::Bar'],
    );

    extends 'My::Class';
}

{
    ok( My::Class6->meta()->meta()->does_role('Role::Bar'),
        q{apply Role::Bar My::Class6->meta() before extends} );
    ok( My::Class6->meta()->meta()->does_role('Role::Foo'),
        q{... and My::Class6->meta() does Role::Foo because My::Class6 extends My::Class} );
}

# This is the hack that used to be needed to work around the
# _fix_metaclass_incompatibility problem. You called extends() (which
# in turn calls _fix_metaclass_imcompatibility) _before_ you apply
# more extensions in the subclass. We wabt to make sure this continues
# to work in the future.
{
    package My::Class7;
    use Mouse;

    # In real usage this would go in a BEGIN block so it happened
    # before apply_metaclass_roles was called by an extension.
    extends 'My::Class';

    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class       => 'My::Class7',
        metaclass_roles => ['Role::Bar'],
    );
}

{
    ok( My::Class7->meta()->meta()->does_role('Role::Bar'),
        q{apply Role::Bar My::Class7->meta() before extends} );
    ok( My::Class7->meta()->meta()->does_role('Role::Foo'),
        q{... and My::Class7->meta() does Role::Foo because My::Class7 extends My::Class} );
}

{
    package My::Class8;
    use Mouse;

    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class                 => 'My::Class8',
        metaclass_roles           => ['Role::Bar'],
        attribute_metaclass_roles => ['Role::Bar'],
    );

    extends 'My::Class';
}

{
    ok( My::Class8->meta()->meta()->does_role('Role::Bar'),
        q{apply Role::Bar My::Class8->meta() before extends} );
    ok( My::Class8->meta()->meta()->does_role('Role::Foo'),
        q{... and My::Class8->meta() does Role::Foo because My::Class8 extends My::Class} );
    ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Bar'),
        q{apply Role::Bar to My::Class8->meta()->attribute_metaclass before extends} );
    ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Foo'),
        q{... and My::Class8->meta()->attribute_metaclass does Role::Foo because My::Class8 extends My::Class} );
}


{
    package My::Class9;
    use Mouse;

    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class                 => 'My::Class9',
        attribute_metaclass_roles => ['Role::Bar'],
    );

    extends 'My::Class';
}

{
    ok( My::Class9->meta()->meta()->does_role('Role::Foo'),
        q{... and My::Class9->meta() does Role::Foo because My::Class9 extends My::Class} );
    ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Bar'),
        q{apply Role::Bar to My::Class9->meta()->attribute_metaclass before extends} );
    ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Foo'),
        q{... and My::Class9->meta()->attribute_metaclass does Role::Foo because My::Class9 extends My::Class} );
}

# This tests applying meta roles to a metaclass's metaclass. This is
# completely insane, but is exactly what happens with
# Fey::Meta::Class::Table. It's a subclass of Mouse::Meta::Class
# itself, and then it _uses_ MouseX::ClassAttribute, so the metaclass
# for Fey::Meta::Class::Table does a role.
#
# At one point this caused a metaclass incompatibility error down
# below, when we applied roles to the metaclass of My::Class10. It's
# all madness but as long as the tests pass we're happy.
{
    package My::Meta::Class2;
    use Mouse;
    extends 'Mouse::Meta::Class';

    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class       => 'My::Meta::Class2',
        metaclass_roles => ['Role::Foo'],
    );
}

{
    package My::Object;
    use Mouse;
    extends 'Mouse::Object';
}

{
    package My::Meta2;

    use Mouse::Exporter;
    Mouse::Exporter->setup_import_methods( also => 'Mouse' );

    sub init_meta {
        shift;
        my %p = @_;

        Mouse->init_meta(
            %p,
            metaclass  => 'My::Meta::Class2',
            base_class => 'My::Object',
        );
    }
}

{
    package My::Class10;
    My::Meta2->import;

    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class       => 'My::Class10',
        metaclass_roles => ['Role::Bar'],
    );
}

{
    ok( My::Class10->meta()->meta()->meta()->does_role('Role::Foo'),
        q{My::Class10->meta()->meta() does Role::Foo } );
    ok( My::Class10->meta()->meta()->does_role('Role::Bar'),
        q{My::Class10->meta()->meta() does Role::Bar } );
    ok( My::Class10->meta()->isa('My::Meta::Class2'),
        q{... and My::Class10->meta still isa(My::Meta::Class2)} );
    ok( My::Class10->isa('My::Object'),
        q{... and My::Class10 still isa(My::Object)} );
}

{
    package My::Constructor;

    use base 'Mouse::Meta::Method::Constructor';
}

{
    package My::Class11;

    use Mouse;

    __PACKAGE__->meta->constructor_class('My::Constructor');

    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class       => 'My::Class11',
        metaclass_roles => ['Role::Foo'],
    );
}

{
    ok( My::Class11->meta()->meta()->does_role('Role::Foo'),
        q{My::Class11->meta()->meta() does Role::Foo } );
    is( My::Class11->meta()->constructor_class, 'My::Constructor',
        q{... and explicitly set constructor_class value is unchanged)} );
}

{
    package ExportsMouse;

    Mouse::Exporter->setup_import_methods(
        also        => 'Mouse',
    );

    sub init_meta {
        shift;
        my %p = @_;
        Mouse->init_meta(%p);
        return Mouse::Util::MetaRole::apply_metaclass_roles(
            for_class       => $p{for_class},
            # Causes us to recurse through init_meta, as we have to
            # load MyMetaclassRole from disk.
           metaclass_roles => [qw/MyMetaclassRole/],
        );
    }
}

lives_ok {
    package UsesExportedMouse;
    ExportsMouse->import;
} 'import module which loads a role from disk during init_meta';

{
    package Foo::Meta::Role;

    use Mouse::Role;
}
{
    package Foo::Role;

    Mouse::Exporter->setup_import_methods(
        also        => 'Mouse::Role',
    );

    sub init_meta {
        shift;
        my %p = @_;
        Mouse::Role->init_meta(%p);
        return Mouse::Util::MetaRole::apply_metaclass_roles(
            for_class              => $p{for_class},
            method_metaclass_roles => [ 'Foo::Meta::Role', ],
        );
    }
}
{
    package Role::Baz;

    Foo::Role->import;

    sub bla {}
}
{
    package My::Class12;

    use Mouse;

    with( 'Role::Baz' );
}
{
    ok(
        My::Class12->meta->does_role( 'Role::Baz' ),
        'role applied'
    );
    my $method = My::Class12->meta->get_method( 'bla' );
    ok(
        $method->meta->does_role( 'Foo::Meta::Role' ),
        'method_metaclass_role applied'
    );
}

{
    package Parent;
    use Mouse;

    Mouse::Util::MetaRole::apply_metaclass_roles(
        for_class               => __PACKAGE__,
        constructor_class_roles => ['Role::Foo'],
    );
}

{
    package Child;

    use Mouse;
    extends 'Parent';
}

{
    ok(
        Parent->meta->constructor_class->meta->can('does_role')
            && Parent->meta->constructor_class->meta->does_role('Role::Foo'),
        'Parent constructor class has metarole from Parent'
    );

TODO:
    {
        local $TODO
            = 'Mouse does not see that the child differs from the parent because it only checks the class and instance metaclasses do determine compatibility';
        ok(
            Child->meta->constructor_class->meta->can('does_role')
                && Child->meta->constructor_class->meta->does_role(
                'Role::Foo'),
            'Child constructor class has metarole from Parent'
        );
    }
}
Commit	Line	Data
41888e7d	1	#!/usr/bin/perl
	2
	3	use strict;
	4	use warnings;
	5
	6	use lib 't/lib', 'lib';
	7
	8	use Test::More tests => 91;
	9	use Test::Exception;
	10
	11	use Mouse::Util::MetaRole;
	12
	13
	14	{
	15	package My::Meta::Class;
	16	use Mouse;
	17	extends 'Mouse::Meta::Class';
	18	}
	19
	20	{
	21	package Role::Foo;
	22	use Mouse::Role;
	23	has 'foo' => ( is => 'ro', default => 10 );
	24	}
	25
	26	{
	27	package My::Class;
	28
	29	use Mouse;
	30	}
	31
	32	{
	33	package My::Role;
	34	use Mouse::Role;
	35	}
	36
	37	{
	38	Mouse::Util::MetaRole::apply_metaclass_roles(
	39	for_class => My::Class->meta,
	40	metaclass_roles => ['Role::Foo'],
	41	);
	42
	43	ok( My::Class->meta()->meta()->does_role('Role::Foo'),
	44	'apply Role::Foo to My::Class->meta()' );
	45	is( My::Class->meta()->foo(), 10,
	46	'... and call foo() on that meta object' );
	47	}
	48
	49	{
	50	Mouse::Util::MetaRole::apply_metaclass_roles(
	51	for_class => 'My::Class',
	52	attribute_metaclass_roles => ['Role::Foo'],
	53	);
	54
	55	ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
	56	q{apply Role::Foo to My::Class->meta()'s attribute metaclass} );
	57	ok( My::Class->meta()->meta()->does_role('Role::Foo'),
	58	'... My::Class->meta() still does Role::Foo' );
	59
	60	My::Class->meta()->add_attribute( 'size', is => 'ro' );
	61	is( My::Class->meta()->get_attribute('size')->foo(), 10,
	62	'... call foo() on an attribute metaclass object' );
	63	}
	64
65	{
66	Mouse::Util::MetaRole::apply_metaclass_roles(
67	for_class => 'My::Class',
68	method_metaclass_roles => ['Role::Foo'],
69	);
70
71	ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
72	q{apply Role::Foo to My::Class->meta()'s method metaclass} );
73	ok( My::Class->meta()->meta()->does_role('Role::Foo'),
74	'... My::Class->meta() still does Role::Foo' );
75	ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
76	q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
77
78	My::Class->meta()->add_method( 'bar' => sub { 'bar' } );
79	is( My::Class->meta()->get_method('bar')->foo(), 10,
80	'... call foo() on a method metaclass object' );
81	}
82
83	{
84	Mouse::Util::MetaRole::apply_metaclass_roles(
85	for_class => 'My::Class',
86	wrapped_method_metaclass_roles => ['Role::Foo'],
87	);
88
89	ok( My::Class->meta()->wrapped_method_metaclass()->meta()->does_role('Role::Foo'),
90	q{apply Role::Foo to My::Class->meta()'s wrapped method metaclass} );
91	ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
92	'... My::Class->meta() still does Role::Foo' );
93	ok( My::Class->meta()->meta()->does_role('Role::Foo'),
94	'... My::Class->meta() still does Role::Foo' );
95	ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
96	q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
97
98	My::Class->meta()->add_after_method_modifier( 'bar' => sub { 'bar' } );
99	is( My::Class->meta()->get_method('bar')->foo(), 10,
100	'... call foo() on a wrapped method metaclass object' );
101	}
102
103	{
104	Mouse::Util::MetaRole::apply_metaclass_roles(
105	for_class => 'My::Class',
106	instance_metaclass_roles => ['Role::Foo'],
107	);
108
109	ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
110	q{apply Role::Foo to My::Class->meta()'s instance metaclass} );
111	ok( My::Class->meta()->meta()->does_role('Role::Foo'),
112	'... My::Class->meta() still does Role::Foo' );
113	ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
114	q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
115	ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
116	q{... My::Class->meta()'s method metaclass still does Role::Foo} );
117
118	is( My::Class->meta()->get_meta_instance()->foo(), 10,
119	'... call foo() on an instance metaclass object' );
120	}
121
122	{
123	Mouse::Util::MetaRole::apply_metaclass_roles(
124	for_class => 'My::Class',
125	constructor_class_roles => ['Role::Foo'],
126	);
127
128	ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
129	q{apply Role::Foo to My::Class->meta()'s constructor class} );
130	ok( My::Class->meta()->meta()->does_role('Role::Foo'),
131	'... My::Class->meta() still does Role::Foo' );
132	ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
133	q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
134	ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
135	q{... My::Class->meta()'s method metaclass still does Role::Foo} );
136	ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
137	q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
138
139	# Actually instantiating the constructor class is too freaking hard!
140	ok( My::Class->meta()->constructor_class()->can('foo'),
141	'... constructor class has a foo method' );
142	}
143
144	{
145	Mouse::Util::MetaRole::apply_metaclass_roles(
146	for_class => 'My::Class',
147	destructor_class_roles => ['Role::Foo'],
148	);
149
150	ok( My::Class->meta()->destructor_class()->meta()->does_role('Role::Foo'),
151	q{apply Role::Foo to My::Class->meta()'s destructor class} );
152	ok( My::Class->meta()->meta()->does_role('Role::Foo'),
153	'... My::Class->meta() still does Role::Foo' );
154	ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
155	q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
156	ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
157	q{... My::Class->meta()'s method metaclass still does Role::Foo} );
158	ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
159	q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
160	ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
161	q{... My::Class->meta()'s constructor class still does Role::Foo} );
162
163	# same problem as the constructor class
164	ok( My::Class->meta()->destructor_class()->can('foo'),
165	'... destructor class has a foo method' );
166	}
167
168	{
169	Mouse::Util::MetaRole::apply_metaclass_roles(
170	for_class => 'My::Role',
171	application_to_class_class_roles => ['Role::Foo'],
172	);
173
174	ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'),
175	q{apply Role::Foo to My::Role->meta's application_to_class class} );
176
177	is( My::Role->meta->application_to_class_class->new->foo, 10,
178	q{... call foo() on an application_to_class instance} );
179	}
180
181	{
182	Mouse::Util::MetaRole::apply_metaclass_roles(
183	for_class => 'My::Role',
184	application_to_role_class_roles => ['Role::Foo'],
185	);
186
187	ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'),
188	q{apply Role::Foo to My::Role->meta's application_to_role class} );
189	ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'),
190	q{... My::Role->meta's application_to_class class still does Role::Foo} );
191
192	is( My::Role->meta->application_to_role_class->new->foo, 10,
193	q{... call foo() on an application_to_role instance} );
194	}
195
196	{
197	Mouse::Util::MetaRole::apply_metaclass_roles(
198	for_class => 'My::Role',
199	application_to_instance_class_roles => ['Role::Foo'],
200	);
201
202	ok( My::Role->meta->application_to_instance_class->meta->does_role('Role::Foo'),
203	q{apply Role::Foo to My::Role->meta's application_to_instance class} );
204	ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'),
205	q{... My::Role->meta's application_to_role class still does Role::Foo} );
206	ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'),
207	q{... My::Role->meta's application_to_class class still does Role::Foo} );
208
209	is( My::Role->meta->application_to_instance_class->new->foo, 10,
210	q{... call foo() on an application_to_instance instance} );
211	}
212
213	{
214	Mouse::Util::MetaRole::apply_base_class_roles(
215	for_class => 'My::Class',
216	roles => ['Role::Foo'],
217	);
218
219	ok( My::Class->meta()->does_role('Role::Foo'),
220	'apply Role::Foo to My::Class base class' );
221	is( My::Class->new()->foo(), 10,
222	'... call foo() on a My::Class object' );
223	}
224
225	{
226	package My::Class2;
227
228	use Mouse;
229	}
230
231	{
232	Mouse::Util::MetaRole::apply_metaclass_roles(
233	for_class => 'My::Class2',
234	metaclass_roles => ['Role::Foo'],
235	attribute_metaclass_roles => ['Role::Foo'],
236	method_metaclass_roles => ['Role::Foo'],
237	instance_metaclass_roles => ['Role::Foo'],
238	constructor_class_roles => ['Role::Foo'],
239	destructor_class_roles => ['Role::Foo'],
240	);
241
242	ok( My::Class2->meta()->meta()->does_role('Role::Foo'),
243	'apply Role::Foo to My::Class2->meta()' );
244	is( My::Class2->meta()->foo(), 10,
245	'... and call foo() on that meta object' );
246	ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
247	q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} );
248	My::Class2->meta()->add_attribute( 'size', is => 'ro' );
249
250	is( My::Class2->meta()->get_attribute('size')->foo(), 10,
251	'... call foo() on an attribute metaclass object' );
252
253	ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
254	q{apply Role::Foo to My::Class2->meta()'s method metaclass} );
255
256	My::Class2->meta()->add_method( 'bar' => sub { 'bar' } );
257	is( My::Class2->meta()->get_method('bar')->foo(), 10,
258	'... call foo() on a method metaclass object' );
259
260	ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
261	q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
262	is( My::Class2->meta()->get_meta_instance()->foo(), 10,
263	'... call foo() on an instance metaclass object' );
264
265	ok( My::Class2->meta()->constructor_class()->meta()->does_role('Role::Foo'),
266	q{apply Role::Foo to My::Class2->meta()'s constructor class} );
267	ok( My::Class2->meta()->constructor_class()->can('foo'),
268	'... constructor class has a foo method' );
269
270	ok( My::Class2->meta()->destructor_class()->meta()->does_role('Role::Foo'),
271	q{apply Role::Foo to My::Class2->meta()'s destructor class} );
272	ok( My::Class2->meta()->destructor_class()->can('foo'),
273	'... destructor class has a foo method' );
274	}
275
276
277	{
278	package My::Meta;
279
280	use Mouse::Exporter;
281	Mouse::Exporter->setup_import_methods( also => 'Mouse' );
282
283	sub init_meta {
284	shift;
285	my %p = @_;
286
287	Mouse->init_meta( %p, metaclass => 'My::Meta::Class' );
288	}
289	}
290
291	{
292	package My::Class3;
293
294	My::Meta->import();
295	}
296
297
298	{
299	Mouse::Util::MetaRole::apply_metaclass_roles(
300	for_class => 'My::Class3',
301	metaclass_roles => ['Role::Foo'],
302	);
303
304	ok( My::Class3->meta()->meta()->does_role('Role::Foo'),
305	'apply Role::Foo to My::Class3->meta()' );
306	is( My::Class3->meta()->foo(), 10,
307	'... and call foo() on that meta object' );
308	ok( ( grep { $_ eq 'My::Meta::Class' } My::Class3->meta()->meta()->superclasses() ),
309	'apply_metaclass_roles() does not interfere with metaclass set via Mouse->init_meta()' );
310	}
311
312	{
313	package Role::Bar;
314	use Mouse::Role;
315	has 'bar' => ( is => 'ro', default => 200 );
316	}
317
318	{
319	package My::Class4;
320	use Mouse;
321	}
322
323	{
324	Mouse::Util::MetaRole::apply_metaclass_roles(
325	for_class => 'My::Class4',
326	metaclass_roles => ['Role::Foo'],
327	);
328
329	ok( My::Class4->meta()->meta()->does_role('Role::Foo'),
330	'apply Role::Foo to My::Class4->meta()' );
331
332	Mouse::Util::MetaRole::apply_metaclass_roles(
333	for_class => 'My::Class4',
334	metaclass_roles => ['Role::Bar'],
335	);
336
337	ok( My::Class4->meta()->meta()->does_role('Role::Bar'),
338	'apply Role::Bar to My::Class4->meta()' );
339	ok( My::Class4->meta()->meta()->does_role('Role::Foo'),
340	'... and My::Class4->meta() still does Role::Foo' );
341	}
342
343	{
344	package My::Class5;
345	use Mouse;
346
347	extends 'My::Class';
348	}
349
350	{
351	ok( My::Class5->meta()->meta()->does_role('Role::Foo'),
352	q{My::Class5->meta()'s does Role::Foo because it extends My::Class} );
353	ok( My::Class5->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
354	q{My::Class5->meta()'s attribute metaclass also does Role::Foo} );
355	ok( My::Class5->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
356	q{My::Class5->meta()'s method metaclass also does Role::Foo} );
357	ok( My::Class5->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
358	q{My::Class5->meta()'s instance metaclass also does Role::Foo} );
359	ok( My::Class5->meta()->constructor_class()->meta()->does_role('Role::Foo'),
360	q{My::Class5->meta()'s constructor class also does Role::Foo} );
361	ok( My::Class5->meta()->destructor_class()->meta()->does_role('Role::Foo'),
362	q{My::Class5->meta()'s destructor class also does Role::Foo} );
363	}
364
365	{
366	Mouse::Util::MetaRole::apply_metaclass_roles(
367	for_class => 'My::Class5',
368	metaclass_roles => ['Role::Bar'],
369	);
370
371	ok( My::Class5->meta()->meta()->does_role('Role::Bar'),
372	q{apply Role::Bar My::Class5->meta()} );
373	ok( My::Class5->meta()->meta()->does_role('Role::Foo'),
374	q{... and My::Class5->meta() still does Role::Foo} );
375	}
376
377	{
378	package My::Class6;
379	use Mouse;
380
381	Mouse::Util::MetaRole::apply_metaclass_roles(
382	for_class => 'My::Class6',
383	metaclass_roles => ['Role::Bar'],
384	);
385
386	extends 'My::Class';
387	}
388
389	{
390	ok( My::Class6->meta()->meta()->does_role('Role::Bar'),
391	q{apply Role::Bar My::Class6->meta() before extends} );
392	ok( My::Class6->meta()->meta()->does_role('Role::Foo'),
393	q{... and My::Class6->meta() does Role::Foo because My::Class6 extends My::Class} );
394	}
395
396	# This is the hack that used to be needed to work around the
397	# _fix_metaclass_incompatibility problem. You called extends() (which
398	# in turn calls _fix_metaclass_imcompatibility) _before_ you apply
399	# more extensions in the subclass. We wabt to make sure this continues
400	# to work in the future.
401	{
402	package My::Class7;
403	use Mouse;
404
405	# In real usage this would go in a BEGIN block so it happened
406	# before apply_metaclass_roles was called by an extension.
407	extends 'My::Class';
408
409	Mouse::Util::MetaRole::apply_metaclass_roles(
410	for_class => 'My::Class7',
411	metaclass_roles => ['Role::Bar'],
412	);
413	}
414
415	{
416	ok( My::Class7->meta()->meta()->does_role('Role::Bar'),
417	q{apply Role::Bar My::Class7->meta() before extends} );
418	ok( My::Class7->meta()->meta()->does_role('Role::Foo'),
419	q{... and My::Class7->meta() does Role::Foo because My::Class7 extends My::Class} );
420	}
421
422	{
423	package My::Class8;
424	use Mouse;
425
426	Mouse::Util::MetaRole::apply_metaclass_roles(
427	for_class => 'My::Class8',
428	metaclass_roles => ['Role::Bar'],
429	attribute_metaclass_roles => ['Role::Bar'],
430	);
431
432	extends 'My::Class';
433	}
434
435	{
436	ok( My::Class8->meta()->meta()->does_role('Role::Bar'),
437	q{apply Role::Bar My::Class8->meta() before extends} );
438	ok( My::Class8->meta()->meta()->does_role('Role::Foo'),
439	q{... and My::Class8->meta() does Role::Foo because My::Class8 extends My::Class} );
440	ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Bar'),
441	q{apply Role::Bar to My::Class8->meta()->attribute_metaclass before extends} );
442	ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Foo'),
443	q{... and My::Class8->meta()->attribute_metaclass does Role::Foo because My::Class8 extends My::Class} );
444	}
445
446
447	{
448	package My::Class9;
449	use Mouse;
450
451	Mouse::Util::MetaRole::apply_metaclass_roles(
452	for_class => 'My::Class9',
453	attribute_metaclass_roles => ['Role::Bar'],
454	);
455
456	extends 'My::Class';
457	}
458
459	{
460	ok( My::Class9->meta()->meta()->does_role('Role::Foo'),
461	q{... and My::Class9->meta() does Role::Foo because My::Class9 extends My::Class} );
462	ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Bar'),
463	q{apply Role::Bar to My::Class9->meta()->attribute_metaclass before extends} );
464	ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Foo'),
465	q{... and My::Class9->meta()->attribute_metaclass does Role::Foo because My::Class9 extends My::Class} );
466	}
467
468	# This tests applying meta roles to a metaclass's metaclass. This is
469	# completely insane, but is exactly what happens with
470	# Fey::Meta::Class::Table. It's a subclass of Mouse::Meta::Class
471	# itself, and then it _uses_ MouseX::ClassAttribute, so the metaclass
472	# for Fey::Meta::Class::Table does a role.
473	#
474	# At one point this caused a metaclass incompatibility error down
475	# below, when we applied roles to the metaclass of My::Class10. It's
476	# all madness but as long as the tests pass we're happy.
477	{
478	package My::Meta::Class2;
479	use Mouse;
480	extends 'Mouse::Meta::Class';
481
482	Mouse::Util::MetaRole::apply_metaclass_roles(
483	for_class => 'My::Meta::Class2',
484	metaclass_roles => ['Role::Foo'],
485	);
486	}
487
488	{
489	package My::Object;
490	use Mouse;
491	extends 'Mouse::Object';
492	}
493
494	{
495	package My::Meta2;
496
497	use Mouse::Exporter;
498	Mouse::Exporter->setup_import_methods( also => 'Mouse' );
499
500	sub init_meta {
501	shift;
502	my %p = @_;
503
504	Mouse->init_meta(
505	%p,
506	metaclass => 'My::Meta::Class2',
507	base_class => 'My::Object',
508	);
509	}
510	}
511
512	{
513	package My::Class10;
514	My::Meta2->import;
515
516	Mouse::Util::MetaRole::apply_metaclass_roles(
517	for_class => 'My::Class10',
518	metaclass_roles => ['Role::Bar'],
519	);
520	}
521
522	{
523	ok( My::Class10->meta()->meta()->meta()->does_role('Role::Foo'),
524	q{My::Class10->meta()->meta() does Role::Foo } );
525	ok( My::Class10->meta()->meta()->does_role('Role::Bar'),
526	q{My::Class10->meta()->meta() does Role::Bar } );
527	ok( My::Class10->meta()->isa('My::Meta::Class2'),
528	q{... and My::Class10->meta still isa(My::Meta::Class2)} );
529	ok( My::Class10->isa('My::Object'),
530	q{... and My::Class10 still isa(My::Object)} );
531	}
532
533	{
534	package My::Constructor;
535
536	use base 'Mouse::Meta::Method::Constructor';
537	}
538
539	{
540	package My::Class11;
541
542	use Mouse;
543
544	__PACKAGE__->meta->constructor_class('My::Constructor');
545
546	Mouse::Util::MetaRole::apply_metaclass_roles(
547	for_class => 'My::Class11',
548	metaclass_roles => ['Role::Foo'],
549	);
550	}
551
552	{
553	ok( My::Class11->meta()->meta()->does_role('Role::Foo'),
554	q{My::Class11->meta()->meta() does Role::Foo } );
555	is( My::Class11->meta()->constructor_class, 'My::Constructor',
556	q{... and explicitly set constructor_class value is unchanged)} );
557	}
558
559	{
560	package ExportsMouse;
561
562	Mouse::Exporter->setup_import_methods(
563	also => 'Mouse',
564	);
565
566	sub init_meta {
567	shift;
568	my %p = @_;
569	Mouse->init_meta(%p);
570	return Mouse::Util::MetaRole::apply_metaclass_roles(
571	for_class => $p{for_class},
572	# Causes us to recurse through init_meta, as we have to
573	# load MyMetaclassRole from disk.
574	metaclass_roles => [qw/MyMetaclassRole/],
575	);
576	}
577	}
578
579	lives_ok {
580	package UsesExportedMouse;
581	ExportsMouse->import;
582	} 'import module which loads a role from disk during init_meta';
583
584	{
585	package Foo::Meta::Role;
586
587	use Mouse::Role;
588	}
589	{
590	package Foo::Role;
591
592	Mouse::Exporter->setup_import_methods(
593	also => 'Mouse::Role',
594	);
595
596	sub init_meta {
597	shift;
598	my %p = @_;
599	Mouse::Role->init_meta(%p);
600	return Mouse::Util::MetaRole::apply_metaclass_roles(
601	for_class => $p{for_class},
602	method_metaclass_roles => [ 'Foo::Meta::Role', ],
603	);
604	}
605	}
606	{
607	package Role::Baz;
608
609	Foo::Role->import;
610
611	sub bla {}
612	}
613	{
614	package My::Class12;
615
616	use Mouse;
617
618	with( 'Role::Baz' );
619	}
620	{
621	ok(
622	My::Class12->meta->does_role( 'Role::Baz' ),
623	'role applied'
624	);
625	my $method = My::Class12->meta->get_method( 'bla' );
626	ok(
627	$method->meta->does_role( 'Foo::Meta::Role' ),
628	'method_metaclass_role applied'
629	);
630	}
631
632	{
633	package Parent;
634	use Mouse;
635
636	Mouse::Util::MetaRole::apply_metaclass_roles(
637	for_class => __PACKAGE__,
638	constructor_class_roles => ['Role::Foo'],
639	);
640	}
641
642	{
643	package Child;
644
645	use Mouse;
646	extends 'Parent';
647	}
648
649	{
650	ok(
651	Parent->meta->constructor_class->meta->can('does_role')
652	&& Parent->meta->constructor_class->meta->does_role('Role::Foo'),
653	'Parent constructor class has metarole from Parent'
654	);
655
656	TODO:
657	{
658	local $TODO
659	= 'Mouse does not see that the child differs from the parent because it only checks the class and instance metaclasses do determine compatibility';
660	ok(
661	Child->meta->constructor_class->meta->can('does_role')
662	&& Child->meta->constructor_class->meta->does_role(
663	'Role::Foo'),
664	'Child constructor class has metarole from Parent'
665	);
666	}
667	}