From: gfx Date: Tue, 17 Nov 2009 07:01:52 +0000 (+0900) Subject: Import t/050_metaclass from Moose X-Git-Tag: 0.40_07~10 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=41888e7dcb98181fea82fda702906a57d5c6a18d;hp=542f20adaffff1539921032f24c8c1893080fc8c Import t/050_metaclass from Moose --- diff --git a/t/050_metaclasses/015_metarole.t b/t/050_metaclasses/015_metarole.t new file mode 100644 index 0000000..361a8b8 --- /dev/null +++ b/t/050_metaclasses/015_metarole.t @@ -0,0 +1,667 @@ +#!/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' + ); + } +} diff --git a/t/050_metaclasses/failing/003_moose_w_metaclass.t b/t/050_metaclasses/failing/003_moose_w_metaclass.t new file mode 100644 index 0000000..19fd54e --- /dev/null +++ b/t/050_metaclasses/failing/003_moose_w_metaclass.t @@ -0,0 +1,56 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 4; +use Test::Exception; + + + +=pod + +This test demonstrates that Mouse will respect +a metaclass previously set with the metaclass +pragma. + +It also checks an error condition where that +metaclass must be a Mouse::Meta::Class subclass +in order to work. + +=cut + + +{ + package Foo::Meta; + use strict; + use warnings; + + use base 'Mouse::Meta::Class'; + + package Foo; + use strict; + use warnings; + use metaclass 'Foo::Meta'; + ::use_ok('Mouse'); +} + +isa_ok(Foo->meta, 'Foo::Meta'); + +{ + package Bar::Meta; + use strict; + use warnings; + + use base 'Class::MOP::Class'; + + package Bar; + use strict; + use warnings; + use metaclass 'Bar::Meta'; + eval 'use Mouse;'; + ::ok($@, '... could not load moose without correct metaclass'); + ::like($@, + qr/^Bar already has a metaclass, but it does not inherit Mouse::Meta::Class/, + '... got the right error too'); +} diff --git a/t/050_metaclasses/failing/004_moose_for_meta.t b/t/050_metaclasses/failing/004_moose_for_meta.t new file mode 100644 index 0000000..21d3a9a --- /dev/null +++ b/t/050_metaclasses/failing/004_moose_for_meta.t @@ -0,0 +1,79 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 16; +use Test::Exception; + + + +=pod + +This test demonstrates the ability to extend +Mouse meta-level classes using Mouse itself. + +=cut + +{ + package My::Meta::Class; + use Mouse; + + extends 'Mouse::Meta::Class'; + + around 'create_anon_class' => sub { + my $next = shift; + my ($self, %options) = @_; + $options{superclasses} = [ 'Mouse::Object' ] + unless exists $options{superclasses}; + $next->($self, %options); + }; +} + +my $anon = My::Meta::Class->create_anon_class(); +isa_ok($anon, 'My::Meta::Class'); +isa_ok($anon, 'Mouse::Meta::Class'); +isa_ok($anon, 'Class::MOP::Class'); + +is_deeply( + [ $anon->superclasses ], + [ 'Mouse::Object' ], + '... got the default superclasses'); + +{ + package My::Meta::Attribute::DefaultReadOnly; + use Mouse; + + extends 'Mouse::Meta::Attribute'; + + around 'new' => sub { + my $next = shift; + my ($self, $name, %options) = @_; + $options{is} = 'ro' + unless exists $options{is}; + $next->($self, $name, %options); + }; +} + +{ + my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo'); + isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly'); + isa_ok($attr, 'Mouse::Meta::Attribute'); + isa_ok($attr, 'Class::MOP::Attribute'); + + ok($attr->has_reader, '... the attribute has a reader (as expected)'); + ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)'); + ok(!$attr->has_accessor, '... the attribute does not have an accessor (as expected)'); +} + +{ + my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo', (is => 'rw')); + isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly'); + isa_ok($attr, 'Mouse::Meta::Attribute'); + isa_ok($attr, 'Class::MOP::Attribute'); + + ok(!$attr->has_reader, '... the attribute does not have a reader (as expected)'); + ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)'); + ok($attr->has_accessor, '... the attribute does have an accessor (as expected)'); +} + diff --git a/t/050_metaclasses/failing/010_extending_and_embedding_back_compat.t b/t/050_metaclasses/failing/010_extending_and_embedding_back_compat.t new file mode 100644 index 0000000..d1e05d5 --- /dev/null +++ b/t/050_metaclasses/failing/010_extending_and_embedding_back_compat.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 7; +use Test::Exception; + + + +BEGIN { + package MyFramework::Base; + use Mouse; + + package MyFramework::Meta::Base; + use Mouse; + + extends 'Mouse::Meta::Class'; + + package MyFramework; + use Mouse; + + sub import { + my $CALLER = caller(); + + strict->import; + warnings->import; + + return if $CALLER eq 'main'; + Mouse::init_meta( $CALLER, 'MyFramework::Base', 'MyFramework::Meta::Base' ); + Mouse->import({ into => $CALLER }); + + return 1; + } +} + +{ + package MyClass; + BEGIN { MyFramework->import } + + has 'foo' => (is => 'rw'); +} + +can_ok( 'MyClass', 'meta' ); + +isa_ok(MyClass->meta, 'MyFramework::Meta::Base'); +isa_ok(MyClass->meta, 'Mouse::Meta::Class'); + +my $obj = MyClass->new(foo => 10); +isa_ok($obj, 'MyClass'); +isa_ok($obj, 'MyFramework::Base'); +isa_ok($obj, 'Mouse::Object'); + +is($obj->foo, 10, '... got the right value'); + + + + diff --git a/t/050_metaclasses/failing/012_moose_exporter.t b/t/050_metaclasses/failing/012_moose_exporter.t new file mode 100644 index 0000000..63126aa --- /dev/null +++ b/t/050_metaclasses/failing/012_moose_exporter.t @@ -0,0 +1,391 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Exception; +BEGIN { + eval "use Test::Output;"; + plan skip_all => "Test::Output is required for this test" if $@; + plan tests => 65; +} + + +{ + package HasOwnImmutable; + + use Mouse; + + no Mouse; + + ::stderr_is( sub { eval q[sub make_immutable { return 'foo' }] }, + '', + 'no warning when defining our own make_immutable sub' ); +} + +{ + is( HasOwnImmutable->make_immutable(), 'foo', + 'HasOwnImmutable->make_immutable does not get overwritten' ); +} + +{ + package MouseX::Empty; + + use Mouse (); + Mouse::Exporter->setup_import_methods( also => 'Mouse' ); +} + +{ + package WantsMouse; + + MouseX::Empty->import(); + + sub foo { 1 } + + ::can_ok( 'WantsMouse', 'has' ); + ::can_ok( 'WantsMouse', 'with' ); + ::can_ok( 'WantsMouse', 'foo' ); + + MouseX::Empty->unimport(); +} + +{ + # Note: it's important that these methods be out of scope _now_, + # after unimport was called. We tried a + # namespace::clean(0.08)-based solution, but had to abandon it + # because it cleans the namespace _later_ (when the file scope + # ends). + ok( ! WantsMouse->can('has'), 'WantsMouse::has() has been cleaned' ); + ok( ! WantsMouse->can('with'), 'WantsMouse::with() has been cleaned' ); + can_ok( 'WantsMouse', 'foo' ); + + # This makes sure that Mouse->init_meta() happens properly + isa_ok( WantsMouse->meta(), 'Mouse::Meta::Class' ); + isa_ok( WantsMouse->new(), 'Mouse::Object' ); + +} + +{ + package MouseX::Sugar; + + use Mouse (); + + sub wrapped1 { + my $meta = shift; + return $meta->name . ' called wrapped1'; + } + + Mouse::Exporter->setup_import_methods( + with_meta => ['wrapped1'], + also => 'Mouse', + ); +} + +{ + package WantsSugar; + + MouseX::Sugar->import(); + + sub foo { 1 } + + ::can_ok( 'WantsSugar', 'has' ); + ::can_ok( 'WantsSugar', 'with' ); + ::can_ok( 'WantsSugar', 'wrapped1' ); + ::can_ok( 'WantsSugar', 'foo' ); + ::is( wrapped1(), 'WantsSugar called wrapped1', + 'wrapped1 identifies the caller correctly' ); + + MouseX::Sugar->unimport(); +} + +{ + ok( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' ); + ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' ); + ok( ! WantsSugar->can('wrapped1'), 'WantsSugar::wrapped1() has been cleaned' ); + can_ok( 'WantsSugar', 'foo' ); +} + +{ + package MouseX::MoreSugar; + + use Mouse (); + + sub wrapped2 { + my $caller = shift; + return $caller . ' called wrapped2'; + } + + sub as_is1 { + return 'as_is1'; + } + + Mouse::Exporter->setup_import_methods( + with_caller => ['wrapped2'], + as_is => ['as_is1'], + also => 'MouseX::Sugar', + ); +} + +{ + package WantsMoreSugar; + + MouseX::MoreSugar->import(); + + sub foo { 1 } + + ::can_ok( 'WantsMoreSugar', 'has' ); + ::can_ok( 'WantsMoreSugar', 'with' ); + ::can_ok( 'WantsMoreSugar', 'wrapped1' ); + ::can_ok( 'WantsMoreSugar', 'wrapped2' ); + ::can_ok( 'WantsMoreSugar', 'as_is1' ); + ::can_ok( 'WantsMoreSugar', 'foo' ); + ::is( wrapped1(), 'WantsMoreSugar called wrapped1', + 'wrapped1 identifies the caller correctly' ); + ::is( wrapped2(), 'WantsMoreSugar called wrapped2', + 'wrapped2 identifies the caller correctly' ); + ::is( as_is1(), 'as_is1', + 'as_is1 works as expected' ); + + MouseX::MoreSugar->unimport(); +} + +{ + ok( ! WantsMoreSugar->can('has'), 'WantsMoreSugar::has() has been cleaned' ); + ok( ! WantsMoreSugar->can('with'), 'WantsMoreSugar::with() has been cleaned' ); + ok( ! WantsMoreSugar->can('wrapped1'), 'WantsMoreSugar::wrapped1() has been cleaned' ); + ok( ! WantsMoreSugar->can('wrapped2'), 'WantsMoreSugar::wrapped2() has been cleaned' ); + ok( ! WantsMoreSugar->can('as_is1'), 'WantsMoreSugar::as_is1() has been cleaned' ); + can_ok( 'WantsMoreSugar', 'foo' ); +} + +{ + package My::Metaclass; + use Mouse; + BEGIN { extends 'Mouse::Meta::Class' } + + package My::Object; + use Mouse; + BEGIN { extends 'Mouse::Object' } + + package HasInitMeta; + + use Mouse (); + + sub init_meta { + shift; + return Mouse->init_meta( @_, + metaclass => 'My::Metaclass', + base_class => 'My::Object', + ); + } + + Mouse::Exporter->setup_import_methods( also => 'Mouse' ); +} + +{ + package NewMeta; + + HasInitMeta->import(); +} + +{ + isa_ok( NewMeta->meta(), 'My::Metaclass' ); + isa_ok( NewMeta->new(), 'My::Object' ); +} + +{ + package MouseX::CircularAlso; + + use Mouse (); + + ::dies_ok( + sub { + Mouse::Exporter->setup_import_methods( + also => [ 'Mouse', 'MouseX::CircularAlso' ], + ); + }, + 'a circular reference in also dies with an error' + ); + + ::like( + $@, + qr/\QCircular reference in 'also' parameter to Mouse::Exporter between MouseX::CircularAlso and MouseX::CircularAlso/, + 'got the expected error from circular reference in also' + ); +} + +{ + package MouseX::NoAlso; + + use Mouse (); + + ::dies_ok( + sub { + Mouse::Exporter->setup_import_methods( + also => [ 'NoSuchThing' ], + ); + }, + 'a package which does not use Mouse::Exporter in also dies with an error' + ); + + ::like( + $@, + qr/\QPackage in also (NoSuchThing) does not seem to use Mouse::Exporter (is it loaded?) at /, + 'got the expected error from a reference in also to a package which is not loaded' + ); +} + +{ + package MouseX::NotExporter; + + use Mouse (); + + ::dies_ok( + sub { + Mouse::Exporter->setup_import_methods( + also => [ 'Mouse::Meta::Method' ], + ); + }, + 'a package which does not use Mouse::Exporter in also dies with an error' + ); + + ::like( + $@, + qr/\QPackage in also (Mouse::Meta::Method) does not seem to use Mouse::Exporter at /, + 'got the expected error from a reference in also to a package which does not use Mouse::Exporter' + ); +} + +{ + package MouseX::OverridingSugar; + + use Mouse (); + + sub has { + my $caller = shift; + return $caller . ' called has'; + } + + Mouse::Exporter->setup_import_methods( + with_caller => ['has'], + also => 'Mouse', + ); +} + +{ + package WantsOverridingSugar; + + MouseX::OverridingSugar->import(); + + ::can_ok( 'WantsOverridingSugar', 'has' ); + ::can_ok( 'WantsOverridingSugar', 'with' ); + ::is( has('foo'), 'WantsOverridingSugar called has', + 'has from MouseX::OverridingSugar is called, not has from Mouse' ); + + MouseX::OverridingSugar->unimport(); +} + +{ + ok( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' ); + ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' ); +} + +{ + package NonExistentExport; + + use Mouse (); + + ::stderr_like { + Mouse::Exporter->setup_import_methods( + also => ['Mouse'], + with_caller => ['does_not_exist'], + ); + } qr/^Trying to export undefined sub NonExistentExport::does_not_exist/, + "warns when a non-existent method is requested to be exported"; +} + +{ + package WantsNonExistentExport; + + NonExistentExport->import; + + ::ok(!__PACKAGE__->can('does_not_exist'), + "undefined subs do not get exported"); +} + +{ + package AllOptions; + use Mouse (); + use Mouse::Exporter; + + Mouse::Exporter->setup_import_methods( + also => ['Mouse'], + with_meta => [ 'with_meta1', 'with_meta2' ], + with_caller => [ 'with_caller1', 'with_caller2' ], + as_is => ['as_is1'], + ); + + sub with_caller1 { + return @_; + } + + sub with_caller2 (&) { + return @_; + } + + sub as_is1 {2} + + sub with_meta1 { + return @_; + } + + sub with_meta2 (&) { + return @_; + } +} + +{ + package UseAllOptions; + + AllOptions->import(); +} + +{ + can_ok( 'UseAllOptions', $_ ) + for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 ); + + { + my ( $caller, $arg1 ) = UseAllOptions::with_caller1(42); + is( $caller, 'UseAllOptions', 'with_caller wrapped sub gets the right caller' ); + is( $arg1, 42, 'with_caller wrapped sub returns argument it was passed' ); + } + + { + my ( $meta, $arg1 ) = UseAllOptions::with_meta1(42); + isa_ok( $meta, 'Mouse::Meta::Class', 'with_meta first argument' ); + is( $arg1, 42, 'with_meta1 returns argument it was passed' ); + } + + is( + prototype( UseAllOptions->can('with_caller2') ), + prototype( AllOptions->can('with_caller2') ), + 'using correct prototype on with_meta function' + ); + + is( + prototype( UseAllOptions->can('with_meta2') ), + prototype( AllOptions->can('with_meta2') ), + 'using correct prototype on with_meta function' + ); +} + +{ + package UseAllOptions; + AllOptions->unimport(); +} + +{ + ok( ! UseAllOptions->can($_), "UseAllOptions::$_ has been unimported" ) + for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 ); +} diff --git a/t/050_metaclasses/failing/013_metaclass_traits.t b/t/050_metaclasses/failing/013_metaclass_traits.t new file mode 100644 index 0000000..a9d644e --- /dev/null +++ b/t/050_metaclasses/failing/013_metaclass_traits.t @@ -0,0 +1,222 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use lib 't/lib', 'lib'; + +use Test::More tests => 32; +use Test::Exception; + +{ + package My::SimpleTrait; + + use Mouse::Role; + + sub simple { return 5 } +} + +{ + package Foo; + + use Mouse -traits => [ 'My::SimpleTrait' ]; +} + +can_ok( Foo->meta(), 'simple' ); +is( Foo->meta()->simple(), 5, + 'Foo->meta()->simple() returns expected value' ); + +{ + package Bar; + + use Mouse -traits => 'My::SimpleTrait'; +} + +can_ok( Bar->meta(), 'simple' ); +is( Bar->meta()->simple(), 5, + 'Foo->meta()->simple() returns expected value' ); + +{ + package My::SimpleTrait2; + + use Mouse::Role; + + # This needs to happen at compile time so it happens before we + # apply traits to Bar + BEGIN { + has 'attr' => + ( is => 'ro', + default => 'something', + ); + } + + sub simple { return 5 } +} + +{ + package Bar; + + use Mouse -traits => [ 'My::SimpleTrait2' ]; +} + +can_ok( Bar->meta(), 'simple' ); +is( Bar->meta()->simple(), 5, + 'Bar->meta()->simple() returns expected value' ); +can_ok( Bar->meta(), 'attr' ); +is( Bar->meta()->attr(), 'something', + 'Bar->meta()->attr() returns expected value' ); + +{ + package My::SimpleTrait3; + + use Mouse::Role; + + BEGIN { + has 'attr2' => + ( is => 'ro', + default => 'something', + ); + } + + sub simple2 { return 55 } +} + +{ + package Baz; + + use Mouse -traits => [ 'My::SimpleTrait2', 'My::SimpleTrait3' ]; +} + +can_ok( Baz->meta(), 'simple' ); +is( Baz->meta()->simple(), 5, + 'Baz->meta()->simple() returns expected value' ); +can_ok( Baz->meta(), 'attr' ); +is( Baz->meta()->attr(), 'something', + 'Baz->meta()->attr() returns expected value' ); +can_ok( Baz->meta(), 'simple2' ); +is( Baz->meta()->simple2(), 55, + 'Baz->meta()->simple2() returns expected value' ); +can_ok( Baz->meta(), 'attr2' ); +is( Baz->meta()->attr2(), 'something', + 'Baz->meta()->attr2() returns expected value' ); + +{ + package My::Trait::AlwaysRO; + + use Mouse::Role; + + around '_process_new_attribute', '_process_inherited_attribute' => + sub { + my $orig = shift; + my ( $self, $name, %args ) = @_; + + $args{is} = 'ro'; + + return $self->$orig( $name, %args ); + }; +} + +{ + package Quux; + + use Mouse -traits => [ 'My::Trait::AlwaysRO' ]; + + has 'size' => + ( is => 'rw', + isa => 'Int', + ); +} + +ok( Quux->meta()->has_attribute('size'), + 'Quux has size attribute' ); +ok( ! Quux->meta()->get_attribute('size')->writer(), + 'size attribute does not have a writer' ); + +{ + package My::Class::Whatever; + + use Mouse::Role; + + sub whatever { 42 } + + package Mouse::Meta::Class::Custom::Trait::Whatever; + + sub register_implementation { + return 'My::Class::Whatever'; + } +} + +{ + package RanOutOfNames; + + use Mouse -traits => [ 'Whatever' ]; +} + +ok( RanOutOfNames->meta()->meta()->has_method('whatever'), + 'RanOutOfNames->meta() has whatever method' ); + +{ + package Role::Foo; + + use Mouse::Role -traits => [ 'My::SimpleTrait' ]; +} + +can_ok( Role::Foo->meta(), 'simple' ); +is( Role::Foo->meta()->simple(), 5, + 'Role::Foo->meta()->simple() returns expected value' ); + +{ + require Mouse::Util::TypeConstraints; + dies_ok( sub { Mouse::Util::TypeConstraints->import( -traits => 'My::SimpleTrait' ) }, + 'cannot provide -traits to an exporting module that does not init_meta' ); + like( $@, qr/does not have an init_meta/, + '... and error provides a useful explanation' ); +} + +{ + package Foo::Subclass; + + use Mouse -traits => [ 'My::SimpleTrait3' ]; + + extends 'Foo'; +} + +can_ok( Foo::Subclass->meta(), 'simple' ); +is( Foo::Subclass->meta()->simple(), 5, + 'Foo::Subclass->meta()->simple() returns expected value' ); +is( Foo::Subclass->meta()->simple2(), 55, + 'Foo::Subclass->meta()->simple2() returns expected value' ); +can_ok( Foo::Subclass->meta(), 'attr2' ); +is( Foo::Subclass->meta()->attr2(), 'something', + 'Foo::Subclass->meta()->attr2() returns expected value' ); + +{ + + package Class::WithAlreadyPresentTrait; + use Mouse -traits => 'My::SimpleTrait'; + + has an_attr => ( is => 'ro' ); +} + +lives_ok { + my $instance = Class::WithAlreadyPresentTrait->new( an_attr => 'value' ); + is( $instance->an_attr, 'value', 'Can get value' ); +} +'Can create instance and access attributes'; + +{ + + package Class::WhichLoadsATraitFromDisk; + + # Any role you like here, the only important bit is that it gets + # loaded from disk and has not already been defined. + use Mouse -traits => 'Role::Parent'; + + has an_attr => ( is => 'ro' ); +} + +lives_ok { + my $instance = Class::WhichLoadsATraitFromDisk->new( an_attr => 'value' ); + is( $instance->an_attr, 'value', 'Can get value' ); +} +'Can create instance and access attributes'; diff --git a/t/050_metaclasses/failing/014_goto_moose_import.t b/t/050_metaclasses/failing/014_goto_moose_import.t new file mode 100644 index 0000000..063d4f0 --- /dev/null +++ b/t/050_metaclasses/failing/014_goto_moose_import.t @@ -0,0 +1,82 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 8; +use Test::Exception; + +# Some packages out in the wild cooperate with Mouse by using goto +# &Mouse::import. we want to make sure it still works. + +{ + package MouseAlike1; + + use strict; + use warnings; + + use Mouse (); + + sub import { + goto &Mouse::import; + } + + sub unimport { + goto &Mouse::unimport; + } +} + +{ + package Foo; + + MouseAlike1->import(); + + ::lives_ok( sub { has( 'size', is => 'bare' ) }, + 'has was exported via MouseAlike1' ); + + MouseAlike1->unimport(); +} + +ok( ! Foo->can('has'), + 'No has sub in Foo after MouseAlike1 is unimported' ); +ok( Foo->can('meta'), + 'Foo has a meta method' ); +isa_ok( Foo->meta(), 'Mouse::Meta::Class' ); + + +{ + package MouseAlike2; + + use strict; + use warnings; + + use Mouse (); + + my $import = \&Mouse::import; + sub import { + goto $import; + } + + my $unimport = \&Mouse::unimport; + sub unimport { + goto $unimport; + } +} + +{ + package Bar; + + MouseAlike2->import(); + + ::lives_ok( sub { has( 'size', is => 'bare' ) }, + 'has was exported via MouseAlike2' ); + + MouseAlike2->unimport(); +} + + +ok( ! Bar->can('has'), + 'No has sub in Bar after MouseAlike2 is unimported' ); +ok( Bar->can('meta'), + 'Bar has a meta method' ); +isa_ok( Bar->meta(), 'Mouse::Meta::Class' ); diff --git a/t/050_metaclasses/failing/015_metarole.t b/t/050_metaclasses/failing/015_metarole.t new file mode 100644 index 0000000..361a8b8 --- /dev/null +++ b/t/050_metaclasses/failing/015_metarole.t @@ -0,0 +1,667 @@ +#!/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' + ); + } +} diff --git a/t/050_metaclasses/failing/016_metarole_w_metaclass_pm.t b/t/050_metaclasses/failing/016_metarole_w_metaclass_pm.t new file mode 100644 index 0000000..e899624 --- /dev/null +++ b/t/050_metaclasses/failing/016_metarole_w_metaclass_pm.t @@ -0,0 +1,109 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 8; + +use Mouse::Util::MetaRole; + +BEGIN +{ + package My::Meta::Class; + use Mouse; + extends 'Mouse::Meta::Class'; +} + +BEGIN +{ + package My::Meta::Attribute; + use Mouse; + extends 'Mouse::Meta::Attribute'; +} + +BEGIN +{ + package My::Meta::Method; + use Mouse; + extends 'Mouse::Meta::Method'; +} + +BEGIN +{ + package My::Meta::Instance; + use Mouse; + extends 'Mouse::Meta::Instance'; +} + +BEGIN +{ + package Role::Foo; + use Mouse::Role; + has 'foo' => ( is => 'ro', default => 10 ); +} + +{ + package My::Class; + + use metaclass 'My::Meta::Class'; + use Mouse; +} + +{ + package My::Class2; + + use metaclass 'My::Meta::Class' => ( + attribute_metaclass => 'My::Meta::Attribute', + method_metaclass => 'My::Meta::Method', + instance_metaclass => 'My::Meta::Instance', + ); + + use Mouse; +} + +{ + Mouse::Util::MetaRole::apply_metaclass_roles( + for_class => 'My::Class', + metaclass_roles => ['Role::Foo'], + ); + + ok( My::Class->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class->meta()' ); + has_superclass( My::Class->meta(), 'My::Meta::Class', + 'apply_metaclass_roles works with metaclass.pm' ); +} + +{ + Mouse::Util::MetaRole::apply_metaclass_roles( + for_class => 'My::Class2', + attribute_metaclass_roles => ['Role::Foo'], + method_metaclass_roles => ['Role::Foo'], + instance_metaclass_roles => ['Role::Foo'], + ); + + ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} ); + has_superclass( My::Class2->meta()->attribute_metaclass(), 'My::Meta::Attribute', + '... and this does not interfere with attribute metaclass set via metaclass.pm' ); + ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s method metaclass} ); + has_superclass( My::Class2->meta()->method_metaclass(), 'My::Meta::Method', + '... and this does not interfere with method metaclass set via metaclass.pm' ); + ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), + q{apply Role::Foo to My::Class2->meta()'s instance metaclass} ); + has_superclass( My::Class2->meta()->instance_metaclass(), 'My::Meta::Instance', + '... and this does not interfere with instance metaclass set via metaclass.pm' ); +} + +# like isa_ok but works with a class name, not just refs +sub has_superclass { + my $thing = shift; + my $parent = shift; + my $desc = shift; + + my %supers = map { $_ => 1 } $thing->meta()->superclasses(); + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + ok( $supers{$parent}, $desc ); +} diff --git a/t/050_metaclasses/failing/017_use_base_of_moose.t b/t/050_metaclasses/failing/017_use_base_of_moose.t new file mode 100644 index 0000000..2b68fd3 --- /dev/null +++ b/t/050_metaclasses/failing/017_use_base_of_moose.t @@ -0,0 +1,37 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use Test::More tests => 4; +use Test::Exception; + +{ + package NoOpTrait; + use Mouse::Role; +} + +{ + package Parent; + use Mouse -traits => 'NoOpTrait'; + + has attr => ( + is => 'rw', + isa => 'Str', + ); +} + +{ + package Child; + use base 'Parent'; +} + +is(Child->meta->name, 'Child', "correct metaclass name"); + +my $child = Child->new(attr => "ibute"); +ok($child, "constructor works"); + +is($child->attr, "ibute", "getter inherited properly"); + +$child->attr("ition"); +is($child->attr, "ition", "setter inherited properly"); diff --git a/t/050_metaclasses/failing/018_throw_error.t b/t/050_metaclasses/failing/018_throw_error.t new file mode 100644 index 0000000..1be8cb5 --- /dev/null +++ b/t/050_metaclasses/failing/018_throw_error.t @@ -0,0 +1,156 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 24; +use Test::Exception; + +{ + + package Foo; + use Mouse; + + has foo => ( is => "ro" ); + + package Bar; + use metaclass ( + metaclass => "Mouse::Meta::Class", + error_class => "Mouse::Error::Croak", + ); + use Mouse; + + has foo => ( is => "ro" ); + + package Baz::Error; + use Mouse; + + has message => ( isa => "Str", is => "ro" ); + has attr => ( isa => "Mouse::Meta::Attribute", is => "ro" ); + has method => ( isa => "Mouse::Meta::Method", is => "ro" ); + has metaclass => ( isa => "Mouse::Meta::Class", is => "ro" ); + has data => ( is => "ro" ); + has line => ( isa => "Int", is => "ro" ); + has file => ( isa => "Str", is => "ro" ); + has last_error => ( isa => "Any", is => "ro" ); + + package Baz; + use metaclass ( + metaclass => "Mouse::Meta::Class", + error_class => "Baz::Error", + ); + use Mouse; + + has foo => ( is => "ro" ); +} + +my $line; +sub blah { $line = __LINE__; shift->foo(4) } + +sub create_error { + eval { + eval { die "Blah" }; + blah(shift); + }; + ok( my $e = $@, "got some error" ); + return { + file => __FILE__, + line => $line, + error => $e, + }; +} + +{ + my $e = create_error( Foo->new ); + ok( !ref( $e->{error} ), "error is a string" ); + like( $e->{error}, qr/line $e->{line}\n.*\n/s, "confess" ); +} + +{ + my $e = create_error( Bar->new ); + ok( !ref( $e->{error} ), "error is a string" ); + like( $e->{error}, qr/line $e->{line}$/s, "croak" ); +} + +{ + my $e = create_error( my $baz = Baz->new ); + isa_ok( $e->{error}, "Baz::Error" ); + unlike( $e->{error}->message, qr/line $e->{line}/s, + "no line info, just a message" ); + isa_ok( $e->{error}->metaclass, "Mouse::Meta::Class", "metaclass" ); + is( $e->{error}->metaclass, Baz->meta, "metaclass value" ); + isa_ok( $e->{error}->attr, "Mouse::Meta::Attribute", "attr" ); + is( $e->{error}->attr, Baz->meta->get_attribute("foo"), "attr value" ); + isa_ok( $e->{error}->method, "Mouse::Meta::Method", "method" ); + is( $e->{error}->method, Baz->meta->get_method("foo"), "method value" ); + is( $e->{error}->line, $e->{line}, "line attr" ); + is( $e->{error}->file, $e->{file}, "file attr" ); + is_deeply( $e->{error}->data, [ $baz, 4 ], "captured args" ); + like( $e->{error}->last_error, qr/Blah/, "last error preserved" ); +} + +{ + package Role::Foo; + use Mouse::Role; + + sub foo { } +} + +{ + package Baz::Sub; + + use Mouse; + extends 'Baz'; + + Mouse::Util::MetaRole::apply_metaclass_roles( + for_class => __PACKAGE__, + metaclass_roles => ['Role::Foo'], + ); +} + +{ + package Baz::Sub::Sub; + use metaclass ( + metaclass => 'Mouse::Meta::Class', + error_class => 'Mouse::Error::Croak', + ); + use Mouse; + + ::dies_ok { extends 'Baz::Sub' } 'error_class is included in metaclass compatibility checks'; +} + +{ + package Foo::Sub; + + use metaclass ( + metaclass => 'Mouse::Meta::Class', + error_class => 'Mouse::Error::Croak', + ); + + use Mouse; + + Mouse::Util::MetaRole::apply_metaclass_roles( + for_class => __PACKAGE__, + metaclass_roles => ['Role::Foo'], + ); +} + +ok( Foo::Sub->meta->error_class->isa('Mouse::Error::Croak'), + q{Foo::Sub's error_class still isa Mouse::Error::Croak} ); + +{ + package Foo::Sub::Sub; + use Mouse; + + ::lives_ok { extends 'Foo::Sub' } 'error_class differs by role so incompat is handled'; + + Mouse::Util::MetaRole::apply_metaclass_roles( + for_class => __PACKAGE__, + error_class_roles => ['Role::Foo'], + ); +} + +ok( Foo::Sub::Sub->meta->error_class->meta->does_role('Role::Foo'), + q{Foo::Sub::Sub's error_class does Role::Foo} ); +ok( Foo::Sub::Sub->meta->error_class->isa('Mouse::Error::Croak'), + q{Foo::Sub::Sub's error_class now subclasses Mouse::Error::Croak} ); diff --git a/t/050_metaclasses/failing/019_create_anon_with_required_attr.t b/t/050_metaclasses/failing/019_create_anon_with_required_attr.t new file mode 100644 index 0000000..3f4d227 --- /dev/null +++ b/t/050_metaclasses/failing/019_create_anon_with_required_attr.t @@ -0,0 +1,87 @@ +#!/usr/bin/perl + +# this functionality may be pushing toward parametric roles/classes +# it's off in a corner and may not be that important + +use strict; +use warnings; + +use Test::More tests => 15; +use Test::Exception; + +{ + package HasFoo; + use Mouse::Role; + has 'foo' => ( + is => 'ro', + isa => 'Str', + required => 1, + ); + +} + +{ + package My::Metaclass; + use Mouse; + extends 'Mouse::Meta::Class'; + with 'HasFoo'; +} + +package main; + +my $anon; +lives_ok { + $anon = My::Metaclass->create_anon_class( foo => 'this' ); +} 'create anon class with required attr'; +isa_ok( $anon, 'My::Metaclass' ); +cmp_ok( $anon->foo, 'eq', 'this', 'foo is this' ); +dies_ok { + $anon = My::Metaclass->create_anon_class(); +} 'failed to create anon class without required attr'; + +my $meta; +lives_ok { + $meta + = My::Metaclass->initialize( 'Class::Name1' => ( foo => 'that' ) ); +} 'initialize a class with required attr'; +isa_ok( $meta, 'My::Metaclass' ); +cmp_ok( $meta->foo, 'eq', 'that', 'foo is that' ); +cmp_ok( $meta->name, 'eq', 'Class::Name1', 'for the correct class' ); +dies_ok { + $meta + = My::Metaclass->initialize( 'Class::Name2' ); +} 'failed to initialize a class without required attr'; + +lives_ok { + eval qq{ + package Class::Name3; + use metaclass 'My::Metaclass' => ( + foo => 'another', + ); + use Mouse; + }; + die $@ if $@; +} 'use metaclass with required attr'; +$meta = Class::Name3->meta; +isa_ok( $meta, 'My::Metaclass' ); +cmp_ok( $meta->foo, 'eq', 'another', 'foo is another' ); +cmp_ok( $meta->name, 'eq', 'Class::Name3', 'for the correct class' ); +dies_ok { + eval qq{ + package Class::Name4; + use metaclass 'My::Metaclass'; + use Mouse; + }; + die $@ if $@; +} 'failed to use metaclass without required attr'; + + +# how do we pass a required attribute to -traits? +dies_ok { + eval qq{ + package Class::Name5; + use Mouse -traits => 'HasFoo'; + }; + die $@ if $@; +} 'failed to use trait without required attr'; + diff --git a/t/050_metaclasses/failing/020_metaclass_parameterized_traits.t b/t/050_metaclasses/failing/020_metaclass_parameterized_traits.t new file mode 100644 index 0000000..416526b --- /dev/null +++ b/t/050_metaclasses/failing/020_metaclass_parameterized_traits.t @@ -0,0 +1,47 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 5; + +{ + package My::Trait; + use Mouse::Role; + + sub reversed_name { + my $self = shift; + scalar reverse $self->name; + } +} + +{ + package My::Class; + use Mouse -traits => [ + 'My::Trait' => { + -alias => { + reversed_name => 'enam', + }, + }, + ]; +} + +{ + package My::Other::Class; + use Mouse -traits => [ + 'My::Trait' => { + -alias => { + reversed_name => 'reversed', + }, + -excludes => 'reversed_name', + }, + ]; +} + +my $meta = My::Class->meta; +is($meta->enam, 'ssalC::yM', 'parameterized trait applied'); +ok(!$meta->can('reversed'), "the method was not installed under the other class' alias"); + +my $other_meta = My::Other::Class->meta; +is($other_meta->reversed, 'ssalC::rehtO::yM', 'parameterized trait applied'); +ok(!$other_meta->can('enam'), "the method was not installed under the other class' alias"); +ok(!$other_meta->can('reversed_name'), "the method was not installed under the original name when that was excluded"); + diff --git a/t/050_metaclasses/failing/021_export_with_prototype.t b/t/050_metaclasses/failing/021_export_with_prototype.t new file mode 100644 index 0000000..469585c --- /dev/null +++ b/t/050_metaclasses/failing/021_export_with_prototype.t @@ -0,0 +1,20 @@ +use lib "t/lib"; +package MyExporter::User; +use MyExporter; + +use Test::More (tests => 4); +use Test::Exception; + +lives_and { + with_prototype { + my $caller = caller(0); + is($caller, 'MyExporter', "With_caller prototype code gets called from MyMouseX"); + }; +} "check function with prototype"; + +lives_and { + as_is_prototype { + my $caller = caller(0); + is($caller, 'MyExporter', "As-is prototype code gets called from MyMouseX"); + }; +} "check function with prototype"; diff --git a/t/050_metaclasses/failing/022_new_metaclass.t b/t/050_metaclasses/failing/022_new_metaclass.t new file mode 100644 index 0000000..059d9d5 --- /dev/null +++ b/t/050_metaclasses/failing/022_new_metaclass.t @@ -0,0 +1,27 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 2; + +do { + package My::Meta::Class; + use Mouse; + BEGIN { extends 'Mouse::Meta::Class' }; + + package Mouse::Meta::Class::Custom::MyMetaClass; + sub register_implementation { 'My::Meta::Class' } +}; + +do { + package My::Class; + use Mouse -metaclass => 'My::Meta::Class'; +}; + +do { + package My::Class::Aliased; + use Mouse -metaclass => 'MyMetaClass'; +}; + +is(My::Class->meta->meta->name, 'My::Meta::Class'); +is(My::Class::Aliased->meta->meta->name, 'My::Meta::Class'); + diff --git a/t/050_metaclasses/failing/023_easy_init_meta.t b/t/050_metaclasses/failing/023_easy_init_meta.t new file mode 100644 index 0000000..6da26d8 --- /dev/null +++ b/t/050_metaclasses/failing/023_easy_init_meta.t @@ -0,0 +1,120 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 13; +use Test::Mouse qw(does_ok); + +{ + package Foo::Trait::Class; + use Mouse::Role; +} + +{ + package Foo::Trait::Attribute; + use Mouse::Role; +} + +{ + package Foo::Role::Base; + use Mouse::Role; +} + +{ + package Foo::Exporter; + use Mouse::Exporter; + + Mouse::Exporter->setup_import_methods( + metaclass_roles => ['Foo::Trait::Class'], + attribute_metaclass_roles => ['Foo::Trait::Attribute'], + base_class_roles => ['Foo::Role::Base'], + ); +} + +{ + package Foo; + use Mouse; + Foo::Exporter->import; + + has foo => (is => 'ro'); + + ::does_ok(Foo->meta, 'Foo::Trait::Class'); + ::does_ok(Foo->meta->get_attribute('foo'), 'Foo::Trait::Attribute'); + ::does_ok('Foo', 'Foo::Role::Base'); +} + +{ + package Foo::Exporter::WithMouse; + use Mouse (); + use Mouse::Exporter; + + my ($import, $unimport, $init_meta) = + Mouse::Exporter->build_import_methods( + also => 'Mouse', + metaclass_roles => ['Foo::Trait::Class'], + attribute_metaclass_roles => ['Foo::Trait::Attribute'], + base_class_roles => ['Foo::Role::Base'], + install => [qw(import unimport)], + ); + + sub init_meta { + my $package = shift; + my %options = @_; + ::pass('custom init_meta was called'); + Mouse->init_meta(%options); + return $package->$init_meta(%options); + } +} + +{ + package Foo2; + Foo::Exporter::WithMouse->import; + + has(foo => (is => 'ro')); + + ::isa_ok('Foo2', 'Mouse::Object'); + ::isa_ok(Foo2->meta, 'Mouse::Meta::Class'); + ::does_ok(Foo2->meta, 'Foo::Trait::Class'); + ::does_ok(Foo2->meta->get_attribute('foo'), 'Foo::Trait::Attribute'); + ::does_ok('Foo2', 'Foo::Role::Base'); +} + +{ + package Foo::Role; + use Mouse::Role; + Foo::Exporter->import; + + ::does_ok(Foo::Role->meta, 'Foo::Trait::Class'); +} + +{ + package Foo::Exporter::WithMouseRole; + use Mouse::Role (); + use Mouse::Exporter; + + my ($import, $unimport, $init_meta) = + Mouse::Exporter->build_import_methods( + also => 'Mouse::Role', + metaclass_roles => ['Foo::Trait::Class'], + attribute_metaclass_roles => ['Foo::Trait::Attribute'], + base_class_roles => ['Foo::Role::Base'], + install => [qw(import unimport)], + ); + + sub init_meta { + my $package = shift; + my %options = @_; + ::pass('custom init_meta was called'); + Mouse::Role->init_meta(%options); + return $package->$init_meta(%options); + } +} + +{ + package Foo2::Role; + Foo::Exporter::WithMouseRole->import; + + ::isa_ok(Foo2::Role->meta, 'Mouse::Meta::Role'); + ::does_ok(Foo2::Role->meta, 'Foo::Trait::Class'); +} diff --git a/t/050_metaclasses/failing/030_metarole_combination.t b/t/050_metaclasses/failing/030_metarole_combination.t new file mode 100644 index 0000000..b2fc134 --- /dev/null +++ b/t/050_metaclasses/failing/030_metarole_combination.t @@ -0,0 +1,233 @@ +use strict; +use warnings; +use Test::More; + +our @applications; + +{ + package CustomApplication; + use Mouse::Role; + + after apply_methods => sub { + my ( $self, $role, $other ) = @_; + $self->apply_custom( $role, $other ); + }; + + sub apply_custom { + shift; + push @applications, [@_]; + } +} + +{ + package CustomApplication::ToClass; + use Mouse::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::ToRole; + use Mouse::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::ToInstance; + use Mouse::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::Composite; + use Mouse::Role; + + with 'CustomApplication'; + + around apply_custom => sub { + my ( $next, $self, $composite, $other ) = @_; + for my $role ( @{ $composite->get_roles } ) { + $self->$next( $role, $other ); + } + }; +} + +{ + package CustomApplication::Composite::ToClass; + use Mouse::Role; + + with 'CustomApplication::Composite'; +} + +{ + package CustomApplication::Composite::ToRole; + use Mouse::Role; + + with 'CustomApplication::Composite'; +} + +{ + package CustomApplication::Composite::ToInstance; + use Mouse::Role; + + with 'CustomApplication::Composite'; +} + +{ + package Role::Composite; + use Mouse::Role; + + around apply_params => sub { + my ( $next, $self, @args ) = @_; + return Mouse::Util::MetaRole::apply_metaclass_roles( + for_class => $self->$next(@args), + application_to_class_class_roles => + ['CustomApplication::Composite::ToClass'], + application_to_role_class_roles => + ['CustomApplication::Composite::ToRole'], + application_to_instance_class_roles => + ['CustomApplication::Composite::ToInstance'], + ); + }; +} + +{ + package Role::WithCustomApplication; + use Mouse::Role; + + has '+composition_class_roles' => ( + default => ['Role::Composite'], + ); +} + +{ + package CustomRole; + Mouse::Exporter->setup_import_methods( + also => 'Mouse::Role', + ); + + sub init_meta { + my ( $self, %options ) = @_; + return Mouse::Util::MetaRole::apply_metaclass_roles( + for_class => Mouse::Role->init_meta(%options), + metaclass_roles => ['Role::WithCustomApplication'], + application_to_class_class_roles => + ['CustomApplication::ToClass'], + application_to_role_class_roles => ['CustomApplication::ToRole'], + application_to_instance_class_roles => + ['CustomApplication::ToInstance'], + ); + } +} + +{ + package My::Role::Normal; + use Mouse::Role; +} + +{ + package My::Role::Special; + CustomRole->import; +} + +ok( My::Role::Normal->meta->isa('Mouse::Meta::Role'), "sanity check" ); +ok( My::Role::Special->meta->isa('Mouse::Meta::Role'), + "using custom application roles does not change the role metaobject's class" +); +ok( My::Role::Special->meta->meta->does_role('Role::WithCustomApplication'), + "the role's metaobject has custom applications" ); +is_deeply( My::Role::Special->meta->composition_class_roles, + ['Role::Composite'], + "the role knows about the specified composition class" ); + +{ + package Foo; + use Mouse; + + local @applications; + with 'My::Role::Special'; + + ::is( @applications, 1, 'one role application' ); + ::is( $applications[0]->[0]->name, 'My::Role::Special', + "the application's first role was My::Role::Special'" ); + ::is( $applications[0]->[1]->name, 'Foo', + "the application provided an additional role" ); +} + +{ + package Bar; + use Mouse::Role; + + local @applications; + with 'My::Role::Special'; + + ::is( @applications, 1 ); + ::is( $applications[0]->[0]->name, 'My::Role::Special' ); + ::is( $applications[0]->[1]->name, 'Bar' ); +} + +{ + package Baz; + use Mouse; + + my $i = Baz->new; + local @applications; + My::Role::Special->meta->apply($i); + + ::is( @applications, 1 ); + ::is( $applications[0]->[0]->name, 'My::Role::Special' ); + ::ok( $applications[0]->[1]->is_anon_class ); + ::ok( $applications[0]->[1]->name->isa('Baz') ); +} + +{ + package Corge; + use Mouse; + + local @applications; + with 'My::Role::Normal', 'My::Role::Special'; + + ::is( @applications, 2 ); + ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); + ::is( $applications[0]->[1]->name, 'Corge' ); + ::is( $applications[1]->[0]->name, 'My::Role::Special' ); + ::is( $applications[1]->[1]->name, 'Corge' ); +} + +{ + package Thud; + use Mouse::Role; + + local @applications; + with 'My::Role::Normal', 'My::Role::Special'; + + ::is( @applications, 2 ); + ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); + ::is( $applications[0]->[1]->name, 'Thud' ); + ::is( $applications[1]->[0]->name, 'My::Role::Special' ); + ::is( $applications[1]->[1]->name, 'Thud' ); +} + +{ + package Garply; + use Mouse; + + my $i = Garply->new; + local @applications; + Mouse::Meta::Role->combine( + [ 'My::Role::Normal' => undef ], + [ 'My::Role::Special' => undef ], + )->apply($i); + + ::is( @applications, 2 ); + ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); + ::ok( $applications[0]->[1]->is_anon_class ); + ::ok( $applications[0]->[1]->name->isa('Garply') ); + ::is( $applications[1]->[0]->name, 'My::Role::Special' ); + ::ok( $applications[1]->[1]->is_anon_class ); + ::ok( $applications[1]->[1]->name->isa('Garply') ); +} + +done_testing; diff --git a/t/050_metaclasses/failing/040_moose_nonmoose_metatrait_init_order.t b/t/050_metaclasses/failing/040_moose_nonmoose_metatrait_init_order.t new file mode 100644 index 0000000..309937f --- /dev/null +++ b/t/050_metaclasses/failing/040_moose_nonmoose_metatrait_init_order.t @@ -0,0 +1,28 @@ +use strict; +use warnings; +{ + package My::Role; + use Mouse::Role; +} +{ + package SomeClass; + use Mouse -traits => 'My::Role'; +} +{ + package SubClassUseBase; + use base qw/SomeClass/; +} +{ + package SubSubClassUseBase; + use base qw/SubClassUseBase/; +} + +use Test::More tests => 2; +use Mouse::Util qw/find_meta does_role/; + +my $subsubclass_meta = Mouse->init_meta( for_class => 'SubSubClassUseBase' ); +ok does_role($subsubclass_meta, 'My::Role'), + 'SubSubClass metaclass does role from grandparent metaclass'; +my $subclass_meta = find_meta('SubClassUseBase'); +ok does_role($subclass_meta, 'My::Role'), + 'SubClass metaclass does role from parent metaclass'; diff --git a/t/050_metaclasses/failing/041_moose_nonmoose_moose_chain_init_meta.t b/t/050_metaclasses/failing/041_moose_nonmoose_moose_chain_init_meta.t new file mode 100644 index 0000000..9db6eb6 --- /dev/null +++ b/t/050_metaclasses/failing/041_moose_nonmoose_moose_chain_init_meta.t @@ -0,0 +1,22 @@ +use strict; +use warnings; +{ + package ParentClass; + use Mouse; +} +{ + package SomeClass; + use base 'ParentClass'; +} +{ + package SubClassUseBase; + use base qw/SomeClass/; + use Mouse; +} + +use Test::More tests => 1; +use Test::Exception; + +lives_ok { + Mouse->init_meta(for_class => 'SomeClass'); +} 'Mouse class => use base => Mouse Class, then Mouse->init_meta on middle class ok';