diff options
Diffstat (limited to 't/metaclasses')
32 files changed, 4333 insertions, 0 deletions
diff --git a/t/metaclasses/create_anon_with_required_attr.t b/t/metaclasses/create_anon_with_required_attr.t new file mode 100644 index 0000000..3a37773 --- /dev/null +++ b/t/metaclasses/create_anon_with_required_attr.t @@ -0,0 +1,86 @@ +use strict; +use warnings; + +# this functionality may be pushing toward parametric roles/classes +# it's off in a corner and may not be that important + +use Test::More; +use Test::Fatal; + +{ + package HasFoo; + use Moose::Role; + has 'foo' => ( + is => 'ro', + isa => 'Str', + required => 1, + ); + +} + +{ + package My::Metaclass; + use Moose; + extends 'Moose::Meta::Class'; + with 'HasFoo'; +} + +package main; + +my $anon; +is( exception { + $anon = My::Metaclass->create_anon_class( foo => 'this' ); +}, undef, 'create anon class with required attr' ); +isa_ok( $anon, 'My::Metaclass' ); +cmp_ok( $anon->foo, 'eq', 'this', 'foo is this' ); +isnt( exception { + $anon = My::Metaclass->create_anon_class(); +}, undef, 'failed to create anon class without required attr' ); + +my $meta; +is( exception { + $meta + = My::Metaclass->initialize( 'Class::Name1' => ( foo => 'that' ) ); +}, undef, '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' ); +isnt( exception { + $meta + = My::Metaclass->initialize( 'Class::Name2' ); +}, undef, 'failed to initialize a class without required attr' ); + +is( exception { + eval qq{ + package Class::Name3; + use metaclass 'My::Metaclass' => ( + foo => 'another', + ); + use Moose; + }; + die $@ if $@; +}, undef, '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' ); +isnt( exception { + eval qq{ + package Class::Name4; + use metaclass 'My::Metaclass'; + use Moose; + }; + die $@ if $@; +}, undef, 'failed to use metaclass without required attr' ); + + +# how do we pass a required attribute to -traits? +isnt( exception { + eval qq{ + package Class::Name5; + use Moose -traits => 'HasFoo'; + }; + die $@ if $@; +}, undef, 'failed to use trait without required attr' ); + +done_testing; diff --git a/t/metaclasses/custom_attr_meta_as_role.t b/t/metaclasses/custom_attr_meta_as_role.t new file mode 100644 index 0000000..d1790d4 --- /dev/null +++ b/t/metaclasses/custom_attr_meta_as_role.t @@ -0,0 +1,20 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +is( exception { + package MooseX::Attribute::Test; + use Moose::Role; +}, undef, 'creating custom attribute "metarole" is okay' ); + +is( exception { + package Moose::Meta::Attribute::Custom::Test; + use Moose; + + extends 'Moose::Meta::Attribute'; + with 'MooseX::Attribute::Test'; +}, undef, 'custom attribute metaclass extending role is okay' ); + +done_testing; diff --git a/t/metaclasses/custom_attr_meta_with_roles.t b/t/metaclasses/custom_attr_meta_with_roles.t new file mode 100644 index 0000000..d6d43bc --- /dev/null +++ b/t/metaclasses/custom_attr_meta_with_roles.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package My::Custom::Meta::Attr; + use Moose; + + extends 'Moose::Meta::Attribute'; +} + +{ + package My::Fancy::Role; + use Moose::Role; + + has 'bling_bling' => ( + metaclass => 'My::Custom::Meta::Attr', + is => 'rw', + isa => 'Str', + ); +} + +{ + package My::Class; + use Moose; + + with 'My::Fancy::Role'; +} + +my $c = My::Class->new; +isa_ok($c, 'My::Class'); + +ok($c->meta->has_attribute('bling_bling'), '... got the attribute'); + +isa_ok($c->meta->get_attribute('bling_bling'), 'My::Custom::Meta::Attr'); + +done_testing; diff --git a/t/metaclasses/easy_init_meta.t b/t/metaclasses/easy_init_meta.t new file mode 100644 index 0000000..b199b6a --- /dev/null +++ b/t/metaclasses/easy_init_meta.t @@ -0,0 +1,126 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose qw(does_ok); + +{ + package Foo::Trait::Class; + use Moose::Role; +} + +{ + package Foo::Trait::Attribute; + use Moose::Role; +} + +{ + package Foo::Role::Base; + use Moose::Role; +} + +{ + package Foo::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + class_metaroles => { + class => ['Foo::Trait::Class'], + attribute => ['Foo::Trait::Attribute'], + }, + role_metaroles => { role => ['Foo::Trait::Class'] }, + base_class_roles => ['Foo::Role::Base'], + ); +} + +{ + package Foo; + use Moose; + 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::WithMoose; + use Moose (); + use Moose::Exporter; + + my ( $import, $unimport, $init_meta ) + = Moose::Exporter->build_import_methods( + also => 'Moose', + class_metaroles => { + class => ['Foo::Trait::Class'], + attribute => ['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'); + Moose->init_meta(%options); + return $package->$init_meta(%options); + } +} + +{ + package Foo2; + Foo::Exporter::WithMoose->import; + + has(foo => (is => 'ro')); + + ::isa_ok('Foo2', 'Moose::Object'); + ::isa_ok(Foo2->meta, 'Moose::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 Moose::Role; + Foo::Exporter->import; + + ::does_ok(Foo::Role->meta, 'Foo::Trait::Class'); +} + +{ + package Foo::Exporter::WithMooseRole; + use Moose::Role (); + use Moose::Exporter; + + my ( $import, $unimport, $init_meta ) + = Moose::Exporter->build_import_methods( + also => 'Moose::Role', + role_metaroles => { + role => ['Foo::Trait::Class'], + attribute => ['Foo::Trait::Attribute'], + }, + install => [qw(import unimport)], + ); + + sub init_meta { + my $package = shift; + my %options = @_; + ::pass('custom init_meta was called'); + Moose::Role->init_meta(%options); + return $package->$init_meta(%options); + } +} + +{ + package Foo2::Role; + Foo::Exporter::WithMooseRole->import; + + ::isa_ok(Foo2::Role->meta, 'Moose::Meta::Role'); + ::does_ok(Foo2::Role->meta, 'Foo::Trait::Class'); +} + +done_testing; diff --git a/t/metaclasses/export_with_prototype.t b/t/metaclasses/export_with_prototype.t new file mode 100644 index 0000000..97227c6 --- /dev/null +++ b/t/metaclasses/export_with_prototype.t @@ -0,0 +1,22 @@ +use lib "t/lib"; +package MyExporter::User; +use MyExporter; + +use Test::More; +use Test::Fatal; + +is( exception { + with_prototype { + my $caller = caller(0); + is($caller, 'MyExporter', "With_caller prototype code gets called from MyMooseX"); + }; +}, undef, "check function with prototype" ); + +is( exception { + as_is_prototype { + my $caller = caller(0); + is($caller, 'MyExporter', "As-is prototype code gets called from MyMooseX"); + }; +}, undef, "check function with prototype" ); + +done_testing; diff --git a/t/metaclasses/exporter_also_with_trait.t b/t/metaclasses/exporter_also_with_trait.t new file mode 100644 index 0000000..ca79ceb --- /dev/null +++ b/t/metaclasses/exporter_also_with_trait.t @@ -0,0 +1,35 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; + +BEGIN { + package My::Meta::Role; + use Moose::Role; +} + +BEGIN { + package My::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => ['Moose'], + class_metaroles => { + class => ['My::Meta::Role'], + }, + ); + $INC{'My/Exporter.pm'} = __FILE__; +} + +{ + package My::Class; + use My::Exporter; +} + +{ + my $meta = My::Class->meta; + isa_ok($meta, 'Moose::Meta::Class'); + does_ok($meta, 'My::Meta::Role'); +} + +done_testing; diff --git a/t/metaclasses/exporter_meta_lookup.t b/t/metaclasses/exporter_meta_lookup.t new file mode 100644 index 0000000..629b48b --- /dev/null +++ b/t/metaclasses/exporter_meta_lookup.t @@ -0,0 +1,62 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Class::Vacuum::Innards; + use Moose; + + package Class::Vacuum; + use Moose (); + use Moose::Exporter; + + sub meta_lookup { $_[0] } + + BEGIN { + Moose::Exporter->setup_import_methods( + also => 'Moose', + meta_lookup => sub { Class::MOP::class_of('Class::Vacuum::Innards') }, + with_meta => ['meta_lookup'], + ); + } +} + +{ + package Victim; + BEGIN { Class::Vacuum->import }; + + has star_rod => ( + is => 'ro', + ); + + ::is(meta_lookup, Class::Vacuum::Innards->meta, "right meta_lookup"); +} + +ok(Class::Vacuum::Innards->can('star_rod'), 'Vacuum stole the star_rod method'); +ok(!Victim->can('star_rod'), 'Victim does not get it at all'); + +{ + package Class::Vacuum::Reexport; + use Moose::Exporter; + + BEGIN { + Moose::Exporter->setup_import_methods(also => 'Class::Vacuum'); + } +} + +{ + package Victim2; + BEGIN { Class::Vacuum::Reexport->import } + + has parasol => ( + is => 'ro', + ); + + ::is(meta_lookup, Class::Vacuum::Innards->meta, "right meta_lookup"); +} + +ok(Class::Vacuum::Innards->can('parasol'), 'Vacuum stole the parasol method'); +ok(!Victim2->can('parasol'), 'Victim does not get it at all'); + +done_testing; diff --git a/t/metaclasses/exporter_sub_names.t b/t/metaclasses/exporter_sub_names.t new file mode 100644 index 0000000..628ed94 --- /dev/null +++ b/t/metaclasses/exporter_sub_names.t @@ -0,0 +1,47 @@ +use strict; +use warnings; + +use Test::CleanNamespaces; +use Test::More; + +diag "ALERT!!!!!! List::MoreUtils 0.407 is incompatible with Moose! You must upgrade or downgrade!" + if do { require List::MoreUtils; List::MoreUtils->VERSION eq '0.407' }; + +{ + package Metarole; + use Moose::Role; +} + +$::HAS_NC_AC = 0; + +{ + package Foo; + use Moose (); + use Moose::Exporter; + { + local $@; + eval 'use namespace::autoclean; $::HAS_NC_AC = 1'; + } + + Moose::Exporter->setup_import_methods( + also => 'Moose', + class_metaroles => { class => ['Metarole'] }, + ); + + my $meta = Class::MOP::Package->initialize(__PACKAGE__); + for my $name (qw( import unimport init_meta )) { + my $body = $meta->get_package_symbol( '&' . $name ); + my ( $package, $sub_name ) = Class::MOP::get_code_info($body); + + ::is( $package, __PACKAGE__, "$name sub is in Foo package" ); + ::is( $sub_name, $name, "$name sub has that name, not __ANON__" ); + } +} + +if ($::HAS_NC_AC) { + $INC{'Foo.pm'} = 1; + namespaces_clean('Foo'); +} + +done_testing(); + diff --git a/t/metaclasses/goto_moose_import.t b/t/metaclasses/goto_moose_import.t new file mode 100644 index 0000000..b6e70be --- /dev/null +++ b/t/metaclasses/goto_moose_import.t @@ -0,0 +1,80 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# Some packages out in the wild cooperate with Moose by using goto +# &Moose::import. we want to make sure it still works. + +{ + package MooseAlike1; + + use strict; + use warnings; + + use Moose (); + + sub import { + goto &Moose::import; + } + + sub unimport { + goto &Moose::unimport; + } +} + +{ + package Foo; + + MooseAlike1->import(); + + ::is( ::exception { has( 'size', is => 'bare' ) }, undef, 'has was exported via MooseAlike1' ); + + MooseAlike1->unimport(); +} + +ok( ! Foo->can('has'), + 'No has sub in Foo after MooseAlike1 is unimported' ); +ok( Foo->can('meta'), + 'Foo has a meta method' ); +isa_ok( Foo->meta(), 'Moose::Meta::Class' ); + + +{ + package MooseAlike2; + + use strict; + use warnings; + + use Moose (); + + my $import = \&Moose::import; + sub import { + goto $import; + } + + my $unimport = \&Moose::unimport; + sub unimport { + goto $unimport; + } +} + +{ + package Bar; + + MooseAlike2->import(); + + ::is( ::exception { has( 'size', is => 'bare' ) }, undef, 'has was exported via MooseAlike2' ); + + MooseAlike2->unimport(); +} + + +ok( ! Bar->can('has'), + 'No has sub in Bar after MooseAlike2 is unimported' ); +ok( Bar->can('meta'), + 'Bar has a meta method' ); +isa_ok( Bar->meta(), 'Moose::Meta::Class' ); + +done_testing; diff --git a/t/metaclasses/immutable_metaclass_compat_bug.t b/t/metaclasses/immutable_metaclass_compat_bug.t new file mode 100644 index 0000000..67a4ffa --- /dev/null +++ b/t/metaclasses/immutable_metaclass_compat_bug.t @@ -0,0 +1,37 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo::Base::Meta::Trait; + use Moose::Role; +} + +{ + package Foo::Base; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Base::Meta::Trait'] }, + ); + __PACKAGE__->meta->make_immutable; +} + +{ + package Foo::Meta::Trait; + use Moose::Role; +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Trait'] } + ); + ::ok(!Foo->meta->is_immutable); + extends 'Foo::Base'; + ::ok(!Foo->meta->is_immutable); +} + +done_testing; diff --git a/t/metaclasses/meta_name.t b/t/metaclasses/meta_name.t new file mode 100644 index 0000000..d947a18 --- /dev/null +++ b/t/metaclasses/meta_name.t @@ -0,0 +1,73 @@ +use strict; +use warnings; +use Test::More; + +{ + # so we don't pick up stuff from Moose::Object + package Base; + sub foo { } # touch it so that 'extends' doesn't try to load it +} + +{ + package Foo; + use Moose; + extends 'Base'; + no Moose; +} +can_ok('Foo', 'meta'); +is(Foo->meta, Class::MOP::class_of('Foo'), 'Foo is a class_of Foo, via Foo->meta'); +isa_ok(Foo->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); + +{ + package Bar; + use Moose -meta_name => 'bar_meta'; + extends 'Base'; + no Moose; +} +ok(!Bar->can('meta'), q{Bar->cant('meta')}); +can_ok('Bar', 'bar_meta'); +is(Bar->bar_meta, Class::MOP::class_of('Bar'), 'Bar is a class_of Bar, via Bar->bar_meta'); +isa_ok(Bar->bar_meta->get_method('bar_meta'), 'Moose::Meta::Method::Meta'); + +{ + package Baz; + use Moose -meta_name => undef; + extends 'Base'; + no Moose; +} +ok(!Baz->can('meta'), q{Baz->cant('meta')}); + +my $universal_method_count = scalar Class::MOP::class_of('UNIVERSAL')->get_all_methods; +# 1 because of the dummy method we installed in Base +is( + ( scalar Class::MOP::class_of('Baz')->get_all_methods ) - $universal_method_count, + 1, + 'Baz has one method', +); + +{ + package Qux; + use Moose -meta_name => 'qux_meta'; +} + +can_ok('Qux', 'qux_meta'); +is(Qux->qux_meta, Class::MOP::class_of('Qux'), 'Qux is a class_of Qux, via Qux->qux_meta'); +isa_ok(Qux->qux_meta->get_method('qux_meta'), 'Moose::Meta::Method::Meta'); + +{ + package FooBar; + sub meta { 42 } + use Moose -meta_name => 'foo_bar_meta'; +} + +is(FooBar->meta, 42, 'FooBar->meta returns 42, not metaclass object'); + +{ + package FooBar::Child; + use Moose -meta_name => 'foo_bar_child_meta'; + extends 'FooBar'; +} + +is(FooBar::Child->meta, 42, 'FooBar::Child->meta returns 42, not metaclass object'); + +done_testing; diff --git a/t/metaclasses/metaclass_compat.t b/t/metaclasses/metaclass_compat.t new file mode 100644 index 0000000..8ef2343 --- /dev/null +++ b/t/metaclasses/metaclass_compat.t @@ -0,0 +1,304 @@ +use strict; +use warnings; +use lib 't/lib'; +use Test::More; +use Test::Fatal; + +our $called = 0; +{ + package Foo::Trait::Class; + use Moose::Role; + + around _inline_BUILDALL => sub { + my $orig = shift; + my $self = shift; + return ( + $self->$orig(@_), + '$::called++;' + ); + } +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + class => ['Foo::Trait::Class'], + } + ); +} + +Foo->new; +is($called, 0, "no calls before inlining"); +Foo->meta->make_immutable; + +Foo->new; +is($called, 1, "inlined constructor has trait modifications"); + +ok(Foo->meta->meta->does_role('Foo::Trait::Class'), + "class has correct traits"); + +{ + package Foo::Sub; + use Moose; + extends 'Foo'; +} + +$called = 0; + +Foo::Sub->new; +is($called, 0, "no calls before inlining"); + +Foo::Sub->meta->make_immutable; + +Foo::Sub->new; +is($called, 1, "inherits trait properly"); + +ok(Foo::Sub->meta->meta->can('does_role') +&& Foo::Sub->meta->meta->does_role('Foo::Trait::Class'), + "subclass inherits traits"); + +{ + package Foo2::Role; + use Moose::Role; +} +{ + package Foo2; + use Moose -traits => ['Foo2::Role']; +} +{ + package Bar2; + use Moose; +} +{ + package Baz2; + use Moose; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo2->meta->meta->name); + ::is( ::exception { $meta->superclasses('Bar2') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar2->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role'], + "still have the role attached"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Foo3::Role; + use Moose::Role; +} +{ + package Bar3; + use Moose -traits => ['Foo3::Role']; +} +{ + package Baz3; + use Moose -traits => ['Foo3::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo2->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Bar3') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar3->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Quux3; + use Moose; +} +{ + package Quuux3; + use Moose -traits => ['Foo3::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo2->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Quux3') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Quux3->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo2::Role', 'Foo3::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} + +{ + package Foo4::Role; + use Moose::Role; +} +{ + package Foo4; + use Moose -traits => ['Foo4::Role']; + __PACKAGE__->meta->make_immutable; +} +{ + package Bar4; + use Moose; +} +{ + package Baz4; + use Moose; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); + ::is( ::exception { $meta->superclasses('Bar4') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar4->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role'], + "still have the role attached"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Foo5::Role; + use Moose::Role; +} +{ + package Bar5; + use Moose -traits => ['Foo5::Role']; +} +{ + package Baz5; + use Moose -traits => ['Foo5::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Bar5') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Bar5->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} +{ + package Quux5; + use Moose; +} +{ + package Quuux5; + use Moose -traits => ['Foo5::Role']; + my $meta = __PACKAGE__->meta; + ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); + ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "reconciled roles correctly"); + ::is( ::exception { $meta->superclasses('Quux5') }, undef, "can still set superclasses" ); + ::isa_ok($meta, Quux5->meta->meta->name); + ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], + ['Foo4::Role', 'Foo5::Role'], + "roles still the same"); + ::ok(!$meta->is_immutable, + "immutable superclass doesn't make this class immutable"); + ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); +} + +{ + package Foo5::Meta::Role; + use Moose::Role; +} +{ + package Foo5::SuperClass::WithMetaRole; + use Moose -traits =>'Foo5::Meta::Role'; +} +{ + package Foo5::SuperClass::After::Attribute; + use Moose; +} +{ + package Foo5; + use Moose; + my @superclasses = ('Foo5::SuperClass::WithMetaRole'); + extends @superclasses; + + has an_attribute_generating_methods => ( is => 'ro' ); + + push(@superclasses, 'Foo5::SuperClass::After::Attribute'); + + ::is( ::exception { + extends @superclasses; + }, undef, 'MI extends after_generated_methods with metaclass roles' ); + ::is( ::exception { + extends reverse @superclasses; + }, undef, 'MI extends after_generated_methods with metaclass roles (reverse)' ); +} + +{ + package Foo6::Meta::Role; + use Moose::Role; +} +{ + package Foo6::SuperClass::WithMetaRole; + use Moose -traits =>'Foo6::Meta::Role'; +} +{ + package Foo6::Meta::OtherRole; + use Moose::Role; +} +{ + package Foo6::SuperClass::After::Attribute; + use Moose -traits =>'Foo6::Meta::OtherRole'; +} +{ + package Foo6; + use Moose; + my @superclasses = ('Foo6::SuperClass::WithMetaRole'); + extends @superclasses; + + has an_attribute_generating_methods => ( is => 'ro' ); + + push(@superclasses, 'Foo6::SuperClass::After::Attribute'); + + ::like( ::exception { + extends @superclasses; + }, qr/compat.*pristine/, 'unsafe MI extends after_generated_methods with metaclass roles' ); + ::like( ::exception { + extends reverse @superclasses; + }, qr/compat.*pristine/, 'unsafe MI extends after_generated_methods with metaclass roles (reverse)' ); +} + +{ + package Foo7::Meta::Trait; + use Moose::Role; +} + +{ + package Foo7; + use Moose -traits => ['Foo7::Meta::Trait']; +} + +{ + package Bar7; + # in an external file + use Moose -traits => ['Bar7::Meta::Trait']; + ::is( ::exception { extends 'Foo7' }, undef, "role reconciliation works" ); +} + +{ + package Bar72; + # in an external file + use Moose -traits => ['Bar7::Meta::Trait2']; + ::is( ::exception { extends 'Foo7' }, undef, "role reconciliation works" ); +} + +done_testing; diff --git a/t/metaclasses/metaclass_compat_no_fixing_bug.t b/t/metaclasses/metaclass_compat_no_fixing_bug.t new file mode 100644 index 0000000..19ec76a --- /dev/null +++ b/t/metaclasses/metaclass_compat_no_fixing_bug.t @@ -0,0 +1,45 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo::Meta::Constructor1; + use Moose::Role; +} + +{ + package Foo::Meta::Constructor2; + use Moose::Role; +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Constructor1'] }, + ); +} + +{ + package Foo::Sub; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Constructor2'] }, + ); + extends 'Foo'; +} + +{ + package Foo::Sub::Sub; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Foo::Meta::Constructor2'] }, + ); + ::is( ::exception { extends 'Foo::Sub' }, undef, "doesn't try to fix if nothing is needed" ); +} + +done_testing; diff --git a/t/metaclasses/metaclass_compat_role_conflicts.t b/t/metaclasses/metaclass_compat_role_conflicts.t new file mode 100644 index 0000000..13cd150 --- /dev/null +++ b/t/metaclasses/metaclass_compat_role_conflicts.t @@ -0,0 +1,63 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + package My::Meta::Role1; + use Moose::Role; + sub foo { 'Role1' } +} +BEGIN { + package My::Meta::Role2; + use Moose::Role; + with 'My::Meta::Role1'; + sub foo { 'Role2' } +} +BEGIN { + package My::Extension; + use Moose::Exporter; + Moose::Exporter->setup_import_methods( + class_metaroles => { + class => ['My::Meta::Role2'], + }, + ); + $INC{'My/Extension.pm'} = __FILE__; +} +BEGIN { + package My::Meta::Role3; + use Moose::Role; +} +BEGIN { + package My::Extension2; + use Moose::Exporter; + Moose::Exporter->setup_import_methods( + class_metaroles => { + class => ['My::Meta::Role3'], + }, + ); + $INC{'My/Extension2.pm'} = __FILE__; +} + +{ + package My::Class1; + use Moose; + use My::Extension; +} + +is(My::Class1->new->meta->foo, 'Role2'); + +{ + package My::Class2; + use Moose; + use My::Extension2; +} +{ + package My::Class3; + use Moose; + use My::Extension; + extends 'My::Class2'; +} + +is(My::Class3->new->meta->foo, 'Role2'); + +done_testing; diff --git a/t/metaclasses/metaclass_parameterized_traits.t b/t/metaclasses/metaclass_parameterized_traits.t new file mode 100644 index 0000000..ca4b5a9 --- /dev/null +++ b/t/metaclasses/metaclass_parameterized_traits.t @@ -0,0 +1,47 @@ +use strict; +use warnings; +use Test::More; + +{ + package My::Trait; + use Moose::Role; + + sub reversed_name { + my $self = shift; + scalar reverse $self->name; + } +} + +{ + package My::Class; + use Moose -traits => [ + 'My::Trait' => { + -alias => { + reversed_name => 'enam', + }, + }, + ]; +} + +{ + package My::Other::Class; + use Moose -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"); + +done_testing; diff --git a/t/metaclasses/metaclass_traits.t b/t/metaclasses/metaclass_traits.t new file mode 100644 index 0000000..bcb9f90 --- /dev/null +++ b/t/metaclasses/metaclass_traits.t @@ -0,0 +1,224 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::Fatal; + +{ + package My::SimpleTrait; + + use Moose::Role; + + sub simple { return 5 } +} + +{ + package Foo; + + use Moose -traits => [ 'My::SimpleTrait' ]; +} + +can_ok( Foo->meta(), 'simple' ); +is( Foo->meta()->simple(), 5, + 'Foo->meta()->simple() returns expected value' ); + +{ + package Bar; + + use Moose -traits => 'My::SimpleTrait'; +} + +can_ok( Bar->meta(), 'simple' ); +is( Bar->meta()->simple(), 5, + 'Foo->meta()->simple() returns expected value' ); + +{ + package My::SimpleTrait2; + + use Moose::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 Moose -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 Moose::Role; + + BEGIN { + has 'attr2' => + ( is => 'ro', + default => 'something', + ); + } + + sub simple2 { return 55 } +} + +{ + package Baz; + + use Moose -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 Moose::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 Moose -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 Moose::Role; + + sub whatever { 42 } + + package Moose::Meta::Class::Custom::Trait::Whatever; + + sub register_implementation { + return 'My::Class::Whatever'; + } +} + +{ + package RanOutOfNames; + + use Moose -traits => [ 'Whatever' ]; +} + +ok( RanOutOfNames->meta()->meta()->has_method('whatever'), + 'RanOutOfNames->meta() has whatever method' ); + +{ + package Role::Foo; + + use Moose::Role -traits => [ 'My::SimpleTrait' ]; +} + +can_ok( Role::Foo->meta(), 'simple' ); +is( Role::Foo->meta()->simple(), 5, + 'Role::Foo->meta()->simple() returns expected value' ); + +{ + require Moose::Util::TypeConstraints; + like( + exception { + Moose::Util::TypeConstraints->import( + -traits => 'My::SimpleTrait' ); + }, + qr/does not have an init_meta/, + 'cannot provide -traits to an exporting module that does not init_meta' + ); +} + +{ + package Foo::Subclass; + + use Moose -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 Moose -traits => 'My::SimpleTrait'; + + has an_attr => ( is => 'ro' ); +} + +is( exception { + my $instance = Class::WithAlreadyPresentTrait->new( an_attr => 'value' ); + is( $instance->an_attr, 'value', 'Can get value' ); +}, undef, '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 Moose -traits => 'Role::Parent'; + + has an_attr => ( is => 'ro' ); +} + +is( exception { + my $instance = Class::WhichLoadsATraitFromDisk->new( an_attr => 'value' ); + is( $instance->an_attr, 'value', 'Can get value' ); +}, undef, 'Can create instance and access attributes' ); + +done_testing; diff --git a/t/metaclasses/metarole.t b/t/metaclasses/metarole.t new file mode 100644 index 0000000..40f2420 --- /dev/null +++ b/t/metaclasses/metarole.t @@ -0,0 +1,725 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::Fatal; + +use Moose::Util::MetaRole; + + +{ + package My::Meta::Class; + use Moose; + extends 'Moose::Meta::Class'; +} + +{ + package Role::Foo; + use Moose::Role; + has 'foo' => ( is => 'ro', default => 10 ); +} + +{ + package My::Class; + + use Moose; +} + +{ + package My::Role; + use Moose::Role; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => My::Class->meta, + class_metaroles => { class => ['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' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { attribute => ['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' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { method => ['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' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { wrapped_method => ['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' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { instance => ['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' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { constructor => ['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' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { destructor => ['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' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Role', + role_metaroles => { application_to_class => ['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} ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Role', + role_metaroles => { application_to_role => ['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} ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Role', + role_metaroles => { application_to_instance => ['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} ); +} + +{ + Moose::Util::MetaRole::apply_base_class_roles( + for => '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 Moose; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class2', + class_metaroles => { + class => ['Role::Foo'], + attribute => ['Role::Foo'], + method => ['Role::Foo'], + instance => ['Role::Foo'], + constructor => ['Role::Foo'], + destructor => ['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 Moose::Exporter; + Moose::Exporter->setup_import_methods( also => 'Moose' ); + + sub init_meta { + shift; + my %p = @_; + + Moose->init_meta( %p, metaclass => 'My::Meta::Class' ); + } +} + +{ + package My::Class3; + + My::Meta->import(); +} + + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class3', + class_metaroles => { class => ['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_metaroles() does not interfere with metaclass set via Moose->init_meta()' ); +} + +{ + package Role::Bar; + use Moose::Role; + has 'bar' => ( is => 'ro', default => 200 ); +} + +{ + package My::Class4; + use Moose; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class4', + class_metaroles => { class => ['Role::Foo'] }, + ); + + ok( My::Class4->meta()->meta()->does_role('Role::Foo'), + 'apply Role::Foo to My::Class4->meta()' ); + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class4', + class_metaroles => { class => ['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 Moose; + + 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} ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class5', + class_metaroles => { class => ['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 Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class6', + class_metaroles => { class => ['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 Moose; + + # In real usage this would go in a BEGIN block so it happened + # before apply_metaroles was called by an extension. + extends 'My::Class'; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class7', + class_metaroles => { class => ['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 Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class8', + class_metaroles => { + class => ['Role::Bar'], + attribute => ['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 Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class9', + class_metaroles => { attribute => ['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 Moose::Meta::Class +# itself, and then it _uses_ MooseX::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 Moose; + extends 'Moose::Meta::Class'; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Meta::Class2', + class_metaroles => { class => ['Role::Foo'] }, + ); +} + +{ + package My::Object; + use Moose; + extends 'Moose::Object'; +} + +{ + package My::Meta2; + + use Moose::Exporter; + Moose::Exporter->setup_import_methods( also => 'Moose' ); + + sub init_meta { + shift; + my %p = @_; + + Moose->init_meta( + %p, + metaclass => 'My::Meta::Class2', + base_class => 'My::Object', + ); + } +} + +{ + package My::Class10; + My::Meta2->import; + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class10', + class_metaroles => { class => ['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 parent 'Moose::Meta::Method::Constructor'; +} + +{ + package My::Class11; + + use Moose; + + __PACKAGE__->meta->constructor_class('My::Constructor'); + + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class11', + class_metaroles => { class => ['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 ExportsMoose; + + Moose::Exporter->setup_import_methods( + also => 'Moose', + ); + + sub init_meta { + shift; + my %p = @_; + Moose->init_meta(%p); + return Moose::Util::MetaRole::apply_metaroles( + for => $p{for_class}, + # Causes us to recurse through init_meta, as we have to + # load MyMetaclassRole from disk. + class_metaroles => { class => [qw/MyMetaclassRole/] }, + ); + } +} + +is( exception { + package UsesExportedMoose; + ExportsMoose->import; +}, undef, 'import module which loads a role from disk during init_meta' ); + +{ + package Foo::Meta::Role; + + use Moose::Role; +} + +{ + package Foo::Role; + + Moose::Exporter->setup_import_methods( + also => 'Moose::Role', + ); + + sub init_meta { + shift; + my %p = @_; + + Moose::Role->init_meta(%p); + + return Moose::Util::MetaRole::apply_metaroles( + for => $p{for_class}, + role_metaroles => { method => ['Foo::Meta::Role'] }, + ); + } +} + +{ + package Role::Baz; + + Foo::Role->import; + + sub bla {} +} + +{ + package My::Class12; + + use Moose; + + 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 Moose; + + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { constructor => ['Role::Foo'] }, + ); +} + +{ + package Child; + + use Moose; + 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' + ); + + 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' + ); +} + +{ + package NotMoosey; + + use metaclass; +} + +{ + like( + exception { + Moose::Util::MetaRole::apply_metaroles( + for => 'Does::Not::Exist', + class_metaroles => { class => ['Role::Foo'] }, + ); + }, + qr/When using Moose::Util::MetaRole.+You passed Does::Not::Exist.+Maybe you need to call.+/, + 'useful error when apply metaroles to a class without a metaclass' + ); + + like( + exception { + Moose::Util::MetaRole::apply_metaroles( + for => 'NotMoosey', + class_metaroles => { class => ['Role::Foo'] }, + ); + }, + qr/When using Moose::Util::MetaRole.+You passed NotMoosey.+we resolved this to a Class::MOP::Class object.+/, + 'useful error when using apply metaroles to a class with a Class::MOP::Class metaclass' + ); + + like( + exception { + Moose::Util::MetaRole::apply_base_class_roles( + for => 'NotMoosey', + roles => { class => ['Role::Foo'] }, + ); + }, + qr/When using Moose::Util::MetaRole.+You passed NotMoosey.+we resolved this to a Class::MOP::Class object.+/, + 'useful error when applying base class to roles to a non-Moose class' + ); + + like( + exception { + Moose::Util::MetaRole::apply_base_class_roles( + for => 'My::Role', + roles => { class => ['Role::Foo'] }, + ); + }, + qr/You can only apply base class roles to a Moose class.+/, + 'useful error when applying base class to roles to a non-Moose class' + ); +} + +done_testing; diff --git a/t/metaclasses/metarole_combination.t b/t/metaclasses/metarole_combination.t new file mode 100644 index 0000000..31a8ed8 --- /dev/null +++ b/t/metaclasses/metarole_combination.t @@ -0,0 +1,238 @@ +use strict; +use warnings; +use Test::More; + +our @applications; + +{ + package CustomApplication; + use Moose::Role; + + after apply_methods => sub { + my ( $self, $role, $other ) = @_; + $self->apply_custom( $role, $other ); + }; + + sub apply_custom { + shift; + push @applications, [@_]; + } +} + +{ + package CustomApplication::ToClass; + use Moose::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::ToRole; + use Moose::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::ToInstance; + use Moose::Role; + + with 'CustomApplication'; +} + +{ + package CustomApplication::Composite; + use Moose::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 Moose::Role; + + with 'CustomApplication::Composite'; +} + +{ + package CustomApplication::Composite::ToRole; + use Moose::Role; + + with 'CustomApplication::Composite'; +} + +{ + package CustomApplication::Composite::ToInstance; + use Moose::Role; + + with 'CustomApplication::Composite'; +} + +{ + package Role::Composite; + use Moose::Role; + + around apply_params => sub { + my ( $next, $self, @args ) = @_; + return Moose::Util::MetaRole::apply_metaroles( + for => $self->$next(@args), + role_metaroles => { + application_to_class => + ['CustomApplication::Composite::ToClass'], + application_to_role => + ['CustomApplication::Composite::ToRole'], + application_to_instance => + ['CustomApplication::Composite::ToInstance'], + }, + ); + }; +} + +{ + package Role::WithCustomApplication; + use Moose::Role; + + around composition_class_roles => sub { + my ($orig, $self) = @_; + return $self->$orig, 'Role::Composite'; + }; +} + +{ + package CustomRole; + Moose::Exporter->setup_import_methods( + also => 'Moose::Role', + ); + + sub init_meta { + my ( $self, %options ) = @_; + return Moose::Util::MetaRole::apply_metaroles( + for => Moose::Role->init_meta(%options), + role_metaroles => { + role => ['Role::WithCustomApplication'], + application_to_class => + ['CustomApplication::ToClass'], + application_to_role => ['CustomApplication::ToRole'], + application_to_instance => + ['CustomApplication::ToInstance'], + }, + ); + } +} + +{ + package My::Role::Normal; + use Moose::Role; +} + +{ + package My::Role::Special; + CustomRole->import; +} + +ok( My::Role::Normal->meta->isa('Moose::Meta::Role'), "sanity check" ); +ok( My::Role::Special->meta->isa('Moose::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 Moose; + + 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 Moose::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 Moose; + + 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 Moose; + + 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 Moose::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 Moose; + + my $i = Garply->new; + local @applications; + Moose::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/metaclasses/metarole_on_anon.t b/t/metaclasses/metarole_on_anon.t new file mode 100644 index 0000000..816e6b4 --- /dev/null +++ b/t/metaclasses/metarole_on_anon.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Meta::Class; +use Moose::Util::MetaRole; + +{ + package Foo; + use Moose; +} + +{ + package Role::Bar; + use Moose::Role; +} + +my $anon_name; + +{ + my $anon_class = Moose::Meta::Class->create_anon_class( + superclasses => ['Foo'], + cache => 1, + ); + + $anon_name = $anon_class->name; + + ok( $anon_name->meta, 'anon class has a metaclass' ); +} + +ok( + $anon_name->meta, + 'cached anon class still has a metaclass after \$anon_class goes out of scope' +); + +Moose::Util::MetaRole::apply_metaroles( + for => $anon_name, + class_metaroles => { + class => ['Role::Bar'], + }, +); + +BAIL_OUT('Cannot continue if the anon class does not have a metaclass') + unless $anon_name->can('meta'); + +my $meta = $anon_name->meta; +ok( $meta, 'cached anon class still has a metaclass applying a metarole' ); + +done_testing; diff --git a/t/metaclasses/metarole_w_metaclass_pm.t b/t/metaclasses/metarole_w_metaclass_pm.t new file mode 100644 index 0000000..c47a208 --- /dev/null +++ b/t/metaclasses/metarole_w_metaclass_pm.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Util::MetaRole; + +BEGIN +{ + package My::Meta::Class; + use Moose; + extends 'Moose::Meta::Class'; +} + +BEGIN +{ + package My::Meta::Attribute; + use Moose; + extends 'Moose::Meta::Attribute'; +} + +BEGIN +{ + package My::Meta::Method; + use Moose; + extends 'Moose::Meta::Method'; +} + +BEGIN +{ + package My::Meta::Instance; + use Moose; + extends 'Moose::Meta::Instance'; +} + +BEGIN +{ + package Role::Foo; + use Moose::Role; + has 'foo' => ( is => 'ro', default => 10 ); +} + +{ + package My::Class; + + use metaclass 'My::Meta::Class'; + use Moose; +} + +{ + package My::Class2; + + use metaclass 'My::Meta::Class' => ( + attribute_metaclass => 'My::Meta::Attribute', + method_metaclass => 'My::Meta::Method', + instance_metaclass => 'My::Meta::Instance', + ); + + use Moose; +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class', + class_metaroles => { class => ['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_metaroles works with metaclass.pm' ); +} + +{ + Moose::Util::MetaRole::apply_metaroles( + for => 'My::Class2', + class_metaroles => { + attribute => ['Role::Foo'], + method => ['Role::Foo'], + instance => ['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 ); +} + +done_testing; diff --git a/t/metaclasses/metaroles_of_metaroles.t b/t/metaclasses/metaroles_of_metaroles.t new file mode 100644 index 0000000..d8533c7 --- /dev/null +++ b/t/metaclasses/metaroles_of_metaroles.t @@ -0,0 +1,67 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package ApplicationMetaRole; + use Moose::Role; + use Moose::Util::MetaRole; + + after apply => sub { + my ($self, $role_source, $role_dest, $args) = @_; + Moose::Util::MetaRole::apply_metaroles + ( + for => $role_dest, + role_metaroles => + { + application_to_role => ['ApplicationMetaRole'], + } + ); + }; +} +{ + package MyMetaRole; + use Moose::Role; + use Moose::Util::MetaRole; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods(also => q<Moose::Role>); + + sub init_meta { + my ($class, %opts) = @_; + Moose::Role->init_meta(%opts); + Moose::Util::MetaRole::apply_metaroles + ( + for => $opts{for_class}, + role_metaroles => + { + application_to_role => ['ApplicationMetaRole'], + } + ); + return $opts{for_class}->meta(); + }; +} + +{ + package MyRole; + use Moose::Role; + + MyMetaRole->import; + + use Moose::Util::TypeConstraints; + + has schema => ( + is => 'ro', + coerce => 1, + ); +} + +{ + package MyTargetRole; + use Moose::Role; + ::is(::exception { with "MyRole" }, undef, + "apply a meta role to a role, which is then applied to yet another role"); +} + +done_testing; diff --git a/t/metaclasses/moose_exporter.t b/t/metaclasses/moose_exporter.t new file mode 100644 index 0000000..dde583a --- /dev/null +++ b/t/metaclasses/moose_exporter.t @@ -0,0 +1,677 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Moose; +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + package HasOwnImmutable; + + use Moose; + + no Moose; + + ::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 MooseX::Empty; + + use Moose (); + Moose::Exporter->setup_import_methods( also => 'Moose' ); +} + +{ + package WantsMoose; + + MooseX::Empty->import(); + + sub foo { 1 } + + ::can_ok( 'WantsMoose', 'has' ); + ::can_ok( 'WantsMoose', 'with' ); + ::can_ok( 'WantsMoose', 'foo' ); + + MooseX::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( ! WantsMoose->can('has'), 'WantsMoose::has() has been cleaned' ); + ok( ! WantsMoose->can('with'), 'WantsMoose::with() has been cleaned' ); + can_ok( 'WantsMoose', 'foo' ); + + # This makes sure that Moose->init_meta() happens properly + isa_ok( WantsMoose->meta(), 'Moose::Meta::Class' ); + isa_ok( WantsMoose->new(), 'Moose::Object' ); + +} + +{ + package MooseX::Sugar; + + use Moose (); + + sub wrapped1 { + my $meta = shift; + return $meta->name . ' called wrapped1'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['wrapped1'], + also => 'Moose', + ); +} + +{ + package WantsSugar; + + MooseX::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' ); + + MooseX::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 MooseX::MoreSugar; + + use Moose (); + + sub wrapped2 { + my $caller = shift->name; + return $caller . ' called wrapped2'; + } + + sub as_is1 { + return 'as_is1'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['wrapped2'], + as_is => ['as_is1'], + also => 'MooseX::Sugar', + ); +} + +{ + package WantsMoreSugar; + + MooseX::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' ); + + MooseX::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 Moose; + BEGIN { extends 'Moose::Meta::Class' } + + package My::Object; + use Moose; + BEGIN { extends 'Moose::Object' } + + package HasInitMeta; + + use Moose (); + + sub init_meta { + shift; + return Moose->init_meta( @_, + metaclass => 'My::Metaclass', + base_class => 'My::Object', + ); + } + + Moose::Exporter->setup_import_methods( also => 'Moose' ); +} + +{ + package NewMeta; + + HasInitMeta->import(); +} + +{ + isa_ok( NewMeta->meta(), 'My::Metaclass' ); + isa_ok( NewMeta->new(), 'My::Object' ); +} + +{ + package MooseX::CircularAlso; + + use Moose (); + + ::like( + ::exception{ Moose::Exporter->setup_import_methods( + also => [ 'Moose', 'MooseX::CircularAlso' ], + ); + }, + qr/\QCircular reference in 'also' parameter to Moose::Exporter between MooseX::CircularAlso and MooseX::CircularAlso/, + 'a circular reference in also dies with an error' + ); +} + +{ + package MooseX::NoAlso; + + use Moose (); + + ::like( + ::exception{ Moose::Exporter->setup_import_methods( + also => ['NoSuchThing'], + ); + }, + qr/\QPackage in also (NoSuchThing) does not seem to use Moose::Exporter (is it loaded?) at /, + 'a package which does not use Moose::Exporter in also dies with an error' + ); +} + +{ + package MooseX::NotExporter; + + use Moose (); + + ::like( + ::exception{ Moose::Exporter->setup_import_methods( + also => ['Moose::Meta::Method'], + ); + }, + qr/\QPackage in also (Moose::Meta::Method) does not seem to use Moose::Exporter at /, + 'a package which does not use Moose::Exporter in also dies with an error' + ); +} + +{ + package MooseX::OverridingSugar; + + use Moose (); + + sub has { + my $caller = shift->name; + return $caller . ' called has'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['has'], + also => 'Moose', + ); +} + +{ + package WantsOverridingSugar; + + MooseX::OverridingSugar->import(); + + ::can_ok( 'WantsOverridingSugar', 'has' ); + ::can_ok( 'WantsOverridingSugar', 'with' ); + ::is( has('foo'), 'WantsOverridingSugar called has', + 'has from MooseX::OverridingSugar is called, not has from Moose' ); + + MooseX::OverridingSugar->unimport(); +} + +{ + ok( ! WantsOverridingSugar->can('has'), 'WantsSugar::has() has been cleaned' ); + ok( ! WantsOverridingSugar->can('with'), 'WantsSugar::with() has been cleaned' ); +} + +{ + package MooseX::OverridingSugar::PassThru; + + sub with { + my $caller = shift->name; + return $caller . ' called with'; + } + + Moose::Exporter->setup_import_methods( + with_meta => ['with'], + also => 'MooseX::OverridingSugar', + ); +} + +{ + + package WantsOverridingSugar::PassThru; + + MooseX::OverridingSugar::PassThru->import(); + + ::can_ok( 'WantsOverridingSugar::PassThru', 'has' ); + ::can_ok( 'WantsOverridingSugar::PassThru', 'with' ); + ::is( + has('foo'), + 'WantsOverridingSugar::PassThru called has', + 'has from MooseX::OverridingSugar is called, not has from Moose' + ); + + ::is( + with('foo'), + 'WantsOverridingSugar::PassThru called with', + 'with from MooseX::OverridingSugar::PassThru is called, not has from Moose' + ); + + + MooseX::OverridingSugar::PassThru->unimport(); +} + +{ + ok( ! WantsOverridingSugar::PassThru->can('has'), 'WantsOverridingSugar::PassThru::has() has been cleaned' ); + ok( ! WantsOverridingSugar::PassThru->can('with'), 'WantsOverridingSugar::PassThru::with() has been cleaned' ); +} + +{ + + package NonExistentExport; + + use Moose (); + + ::stderr_like { + Moose::Exporter->setup_import_methods( + also => ['Moose'], + with_meta => ['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 Moose (); + use Moose::Deprecated -api_version => '0.88'; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => ['Moose'], + with_meta => [ 'with_meta1', 'with_meta2' ], + with_caller => [ 'with_caller1', 'with_caller2' ], + as_is => ['as_is1', \&Foreign::Class::as_is2, 'Foreign::Class::as_is3'], + ); + + sub with_caller1 { + return @_; + } + + sub with_caller2 (&) { + return @_; + } + + sub as_is1 {2} + + sub Foreign::Class::as_is2 { return 'as_is2' } + sub Foreign::Class::as_is3 { return 'as_is3' } + + 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 as_is2 as_is3 ); + + { + 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, 'Moose::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 as_is2 as_is3 ); +} + +{ + package InitMetaError; + use Moose::Exporter; + use Moose (); + Moose::Exporter->setup_import_methods(also => ['Moose']); + sub init_meta { + my $package = shift; + my %options = @_; + Moose->init_meta(%options, metaclass => 'Not::Loaded'); + } +} + +{ + package InitMetaError::Role; + use Moose::Exporter; + use Moose::Role (); + Moose::Exporter->setup_import_methods(also => ['Moose::Role']); + sub init_meta { + my $package = shift; + my %options = @_; + Moose::Role->init_meta(%options, metaclass => 'Not::Loaded'); + } +} + +{ + package WantsInvalidMetaclass; + ::like( + ::exception { InitMetaError->import }, + qr/The Metaclass Not::Loaded must be loaded\. \(Perhaps you forgot to 'use Not::Loaded'\?\)/, + "error when wanting a nonexistent metaclass" + ); +} + +{ + package WantsInvalidMetaclass::Role; + ::like( + ::exception { InitMetaError::Role->import }, + qr/The Metaclass Not::Loaded must be loaded\. \(Perhaps you forgot to 'use Not::Loaded'\?\)/, + "error when wanting a nonexistent metaclass" + ); +} + +{ + my @init_metas_called; + + BEGIN { + package MultiLevelExporter1; + use Moose::Exporter; + + sub foo { 1 } + sub bar { 1 } + sub baz { 1 } + sub quux { 1 } + + Moose::Exporter->setup_import_methods( + with_meta => [qw(foo bar baz quux)], + ); + + sub init_meta { + push @init_metas_called, 1; + } + + $INC{'MultiLevelExporter1.pm'} = __FILE__; + } + + BEGIN { + package MultiLevelExporter2; + use Moose::Exporter; + + sub bar { 2 } + sub baz { 2 } + sub quux { 2 } + + Moose::Exporter->setup_import_methods( + also => ['MultiLevelExporter1'], + with_meta => [qw(bar baz quux)], + ); + + sub init_meta { + push @init_metas_called, 2; + } + + $INC{'MultiLevelExporter2.pm'} = __FILE__; + } + + BEGIN { + package MultiLevelExporter3; + use Moose::Exporter; + + sub baz { 3 } + sub quux { 3 } + + Moose::Exporter->setup_import_methods( + also => ['MultiLevelExporter2'], + with_meta => [qw(baz quux)], + ); + + sub init_meta { + push @init_metas_called, 3; + } + + $INC{'MultiLevelExporter3.pm'} = __FILE__; + } + + BEGIN { + package MultiLevelExporter4; + use Moose::Exporter; + + sub quux { 4 } + + Moose::Exporter->setup_import_methods( + also => ['MultiLevelExporter3'], + with_meta => [qw(quux)], + ); + + sub init_meta { + push @init_metas_called, 4; + } + + $INC{'MultiLevelExporter4.pm'} = __FILE__; + } + + BEGIN { @init_metas_called = () } + { + package UsesMulti1; + use Moose; + use MultiLevelExporter1; + ::is(foo(), 1); + ::is(bar(), 1); + ::is(baz(), 1); + ::is(quux(), 1); + } + use Data::Dumper; + BEGIN { is_deeply(\@init_metas_called, [ 1 ]) || diag(Dumper(\@init_metas_called)) } + + BEGIN { @init_metas_called = () } + { + package UsesMulti2; + use Moose; + use MultiLevelExporter2; + ::is(foo(), 1); + ::is(bar(), 2); + ::is(baz(), 2); + ::is(quux(), 2); + } + BEGIN { is_deeply(\@init_metas_called, [ 2, 1 ]) || diag(Dumper(\@init_metas_called)) } + + BEGIN { @init_metas_called = () } + { + package UsesMulti3; + use Moose; + use MultiLevelExporter3; + ::is(foo(), 1); + ::is(bar(), 2); + ::is(baz(), 3); + ::is(quux(), 3); + } + BEGIN { is_deeply(\@init_metas_called, [ 3, 2, 1 ]) || diag(Dumper(\@init_metas_called)) } + + BEGIN { @init_metas_called = () } + { + package UsesMulti4; + use Moose; + use MultiLevelExporter4; + ::is(foo(), 1); + ::is(bar(), 2); + ::is(baz(), 3); + ::is(quux(), 4); + } + BEGIN { is_deeply(\@init_metas_called, [ 4, 3, 2, 1 ]) || diag(Dumper(\@init_metas_called)) } +} + +# Using "also => [ 'MooseX::UsesAlsoMoose', 'MooseX::SomethingElse' ]" should +# continue to work. The init_meta order needs to be MooseX::CurrentExporter, +# MooseX::UsesAlsoMoose, Moose, MooseX::SomethingElse. This is a pretty ugly +# and messed up use case, but necessary until we come up with a better way to +# do it. + +{ + my @init_metas_called; + + BEGIN { + package AlsoTest::Role1; + use Moose::Role; + } + + BEGIN { + package AlsoTest1; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => [ 'Moose' ], + ); + + sub init_meta { + shift; + my %opts = @_; + ::ok(!Class::MOP::class_of($opts{for_class})); + push @init_metas_called, 1; + } + + $INC{'AlsoTest1.pm'} = __FILE__; + } + + BEGIN { + package AlsoTest2; + use Moose::Exporter; + use Moose::Util::MetaRole (); + + Moose::Exporter->setup_import_methods; + + sub init_meta { + shift; + my %opts = @_; + ::ok(Class::MOP::class_of($opts{for_class})); + Moose::Util::MetaRole::apply_metaroles( + for => $opts{for_class}, + class_metaroles => { + class => ['AlsoTest::Role1'], + }, + ); + push @init_metas_called, 2; + } + + $INC{'AlsoTest2.pm'} = __FILE__; + } + + BEGIN { + package AlsoTest3; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => [ 'AlsoTest1', 'AlsoTest2' ], + ); + + sub init_meta { + shift; + my %opts = @_; + ::ok(!Class::MOP::class_of($opts{for_class})); + push @init_metas_called, 3; + } + + $INC{'AlsoTest3.pm'} = __FILE__; + } + + BEGIN { @init_metas_called = () } + { + package UsesAlsoTest3; + use AlsoTest3; + } + use Data::Dumper; + BEGIN { + is_deeply(\@init_metas_called, [ 3, 1, 2 ]) + || diag(Dumper(\@init_metas_called)); + isa_ok(Class::MOP::class_of('UsesAlsoTest3'), 'Moose::Meta::Class'); + does_ok(Class::MOP::class_of('UsesAlsoTest3'), 'AlsoTest::Role1'); + } + +} + +done_testing; diff --git a/t/metaclasses/moose_exporter_trait_aliases.t b/t/metaclasses/moose_exporter_trait_aliases.t new file mode 100644 index 0000000..633674d --- /dev/null +++ b/t/metaclasses/moose_exporter_trait_aliases.t @@ -0,0 +1,88 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Attribute::Trait::Awesome; + use Moose::Role; +} + +BEGIN { + package Awesome::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + trait_aliases => ['Attribute::Trait::Awesome'], + ); +} + +{ + package Awesome; + use Moose; + BEGIN { Awesome::Exporter->import } + + has foo => ( + traits => [Awesome], + is => 'ro', + ); + ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); + + no Moose; + BEGIN { Awesome::Exporter->unimport } + + my $val = eval "Awesome"; + ::like($@, qr/Bareword "Awesome" not allowed/, "unimported properly"); + ::is($val, undef, "unimported properly"); +} + +BEGIN { + package Awesome2::Exporter; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + trait_aliases => [ + [ 'Attribute::Trait::Awesome' => 'Awesome2' ], + ], + ); +} + +{ + package Awesome2; + use Moose; + BEGIN { Awesome2::Exporter->import } + + has foo => ( + traits => [Awesome2], + is => 'ro', + ); + ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); + + BEGIN { Awesome2::Exporter->unimport } + + my $val = eval "Awesome2"; + ::like($@, qr/Bareword "Awesome2" not allowed/, "unimported properly"); + ::is($val, undef, "unimported properly"); +} + +{ + package Awesome2::Rename; + use Moose; + BEGIN { Awesome2::Exporter->import(Awesome2 => { -as => 'emosewA' }) } + + has foo => ( + traits => [emosewA], + is => 'ro', + ); + ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); + + BEGIN { Awesome2::Exporter->unimport } + + { our $TODO; local $TODO = "unimporting renamed subs currently doesn't work"; + my $val = eval "emosewA"; + ::like($@, qr/Bareword "emosewA" not allowed/, "unimported properly"); + ::is($val, undef, "unimported properly"); + } +} + +done_testing; diff --git a/t/metaclasses/moose_for_meta.t b/t/metaclasses/moose_for_meta.t new file mode 100644 index 0000000..8956380 --- /dev/null +++ b/t/metaclasses/moose_for_meta.t @@ -0,0 +1,76 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +This test demonstrates the ability to extend +Moose meta-level classes using Moose itself. + +=cut + +{ + package My::Meta::Class; + use Moose; + + extends 'Moose::Meta::Class'; + + around 'create_anon_class' => sub { + my $next = shift; + my ($self, %options) = @_; + $options{superclasses} = [ 'Moose::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, 'Moose::Meta::Class'); +isa_ok($anon, 'Class::MOP::Class'); + +is_deeply( + [ $anon->superclasses ], + [ 'Moose::Object' ], + '... got the default superclasses'); + +{ + package My::Meta::Attribute::DefaultReadOnly; + use Moose; + + extends 'Moose::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, 'Moose::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, 'Moose::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)'); +} + +done_testing; diff --git a/t/metaclasses/moose_nonmoose_metatrait_init_order.t b/t/metaclasses/moose_nonmoose_metatrait_init_order.t new file mode 100644 index 0000000..56f7b36 --- /dev/null +++ b/t/metaclasses/moose_nonmoose_metatrait_init_order.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +{ + package My::Role; + use Moose::Role; +} +{ + package SomeClass; + use Moose -traits => 'My::Role'; +} +{ + package SubClassUseBase; + use parent -norequire => 'SomeClass'; +} +{ + package SubSubClassUseBase; + use parent -norequire => 'SubClassUseBase'; +} + +use Test::More; +use Moose::Util qw/find_meta does_role/; + +my $subsubclass_meta = Moose->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'; + +done_testing; diff --git a/t/metaclasses/moose_nonmoose_moose_chain_init_meta.t b/t/metaclasses/moose_nonmoose_moose_chain_init_meta.t new file mode 100644 index 0000000..31df803 --- /dev/null +++ b/t/metaclasses/moose_nonmoose_moose_chain_init_meta.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +{ + package ParentClass; + use Moose; +} +{ + package SomeClass; + use parent -norequire => 'ParentClass'; +} +{ + package SubClassUseBase; + use parent -norequire => 'SomeClass'; + use Moose; +} + +use Test::More; +use Test::Fatal; + +is( exception { + Moose->init_meta(for_class => 'SomeClass'); +}, undef, 'Moose class => use parent => Moose Class, then Moose->init_meta on middle class ok' ); + +done_testing; diff --git a/t/metaclasses/moose_w_metaclass.t b/t/metaclasses/moose_w_metaclass.t new file mode 100644 index 0000000..41f9de0 --- /dev/null +++ b/t/metaclasses/moose_w_metaclass.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +This test demonstrates that Moose will respect +a metaclass previously set with the metaclass +pragma. + +It also checks an error condition where that +metaclass must be a Moose::Meta::Class subclass +in order to work. + +=cut + + +{ + package Foo::Meta; + use strict; + use warnings; + + use parent 'Moose::Meta::Class'; + + package Foo; + use strict; + use warnings; + use metaclass 'Foo::Meta'; + ::use_ok('Moose'); +} + +isa_ok(Foo->meta, 'Foo::Meta'); + +{ + package Bar::Meta; + use strict; + use warnings; + + use parent 'Class::MOP::Class'; + + package Bar; + use strict; + use warnings; + use metaclass 'Bar::Meta'; + eval 'use Moose;'; + ::ok($@, '... could not load moose without correct metaclass'); + ::like($@, + qr/^Bar already has a metaclass, but it does not inherit Moose::Meta::Class/, + '... got the right error too'); +} + +done_testing; diff --git a/t/metaclasses/new_metaclass.t b/t/metaclasses/new_metaclass.t new file mode 100644 index 0000000..7d439b1 --- /dev/null +++ b/t/metaclasses/new_metaclass.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More; + +do { + package My::Meta::Class; + use Moose; + BEGIN { extends 'Moose::Meta::Class' }; + + package Moose::Meta::Class::Custom::MyMetaClass; + sub register_implementation { 'My::Meta::Class' } +}; + +do { + package My::Class; + use Moose -metaclass => 'My::Meta::Class'; +}; + +do { + package My::Class::Aliased; + use Moose -metaclass => 'MyMetaClass'; +}; + +is(My::Class->meta->meta->name, 'My::Meta::Class'); +is(My::Class::Aliased->meta->meta->name, 'My::Meta::Class'); + +done_testing; diff --git a/t/metaclasses/new_object_BUILD.t b/t/metaclasses/new_object_BUILD.t new file mode 100644 index 0000000..22b37c8 --- /dev/null +++ b/t/metaclasses/new_object_BUILD.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; + +my $called; +{ + package Foo; + use Moose; + + sub BUILD { $called++ } +} + +Foo->new; +is($called, 1, "BUILD called from ->new"); +$called = 0; +Foo->meta->new_object; +is($called, 1, "BUILD called from ->meta->new_object"); + +done_testing; diff --git a/t/metaclasses/overloading.t b/t/metaclasses/overloading.t new file mode 100644 index 0000000..31cd907 --- /dev/null +++ b/t/metaclasses/overloading.t @@ -0,0 +1,480 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Sub::Name qw( subname ); + +my $quote = qr/['`"]/; + +{ + package Foo; + use Moose; +} + +{ + my $meta = Foo->meta; + + subtest( + 'Foo class (not overloaded)', + sub { + ok( !$meta->is_overloaded, 'is not overloaded' ); + + ok( + !$meta->has_overloaded_operator('+'), + 'has no + overloading' + ); + ok( + !$meta->has_overloaded_operator('-'), + 'has no - overloading' + ); + + is_deeply( + [ $meta->get_overload_list ], [], + '->get_overload_list returns an empty list' + ); + + is_deeply( + [ $meta->get_all_overloaded_operators ], [], + '->get_all_overloaded_operators return an empty list' + ); + + is( + $meta->get_overloaded_operator('+'), undef, + 'get_overloaded_operator(+) returns undef' + ); + is( + $meta->get_overloaded_operator('-'), undef, + 'get_overloaded_operator(-) returns undef' + ); + } + ); +} + +my $plus = 0; +my $plus_impl; + +BEGIN { + $plus_impl = sub { $plus = 1; 42 } +} +{ + package Foo::Overloaded; + use Moose; + use overload '+' => $plus_impl; +} + +{ + my $meta = Foo::Overloaded->meta; + + subtest( + 'Foo::Overload class (overloaded with coderef)', + sub { + ok( $meta->is_overloaded, 'is overloaded' ); + + ok( + $meta->has_overloaded_operator('+'), + 'has + overloading' + ); + ok( + !$meta->has_overloaded_operator('-'), + 'has no - overloading' + ); + + is_deeply( + [ $meta->get_overload_list ], ['+'], + '->get_overload_list returns (+) ' + ); + + my @overloads = $meta->get_all_overloaded_operators; + is( + scalar(@overloads), 1, + '->get_all_overloaded_operators returns 1 operator' + ); + my $plus_overload = $overloads[0]; + isa_ok( + $plus_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( $plus_overload->operator, '+', 'operator for overload is +' ); + is( + $plus_overload->coderef, $plus_impl, + 'coderef for overload matches sub we passed' + ); + is( + $plus_overload->coderef_package, 'main', + 'coderef package for overload is main' + ); + is( + $plus_overload->coderef_name, '__ANON__', + 'coderef name for overload is __ANON__' + ); + ok( + $plus_overload->is_anonymous, + 'overload is anonymous' + ); + ok( + !$plus_overload->has_method_name, + 'overload has no method name' + ); + ok( + !$plus_overload->has_method, + 'overload has no method' + ); + is( + $plus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + my $plus_overload2 = $meta->get_overloaded_operator('+'); + is( + $plus_overload2, $plus_overload, + '->get_overloaded_operator(+) returns the same operator on each call' + ); + + is( $plus, 0, '+ overloading has not been called' ); + is( + Foo::Overloaded->new + Foo::Overloaded->new, 42, + '+ overloading returns 42' + ); + is( $plus, 1, '+ overloading was called once' ); + + ok( + $plus_overload->_is_equal_to($plus_overload2), + '_is_equal_to returns true for the exact same object' + ); + + my $plus_overload3 = Class::MOP::Overload->new( + operator => '+', + coderef => $plus_impl, + coderef_package => 'main', + coderef_name => '__ANON__', + ); + + ok( + $plus_overload->_is_equal_to($plus_overload3), + '_is_equal_to returns true for object with the same properties' + ); + + my $minus = 0; + my $minus_impl + = subname( 'overload_minus', sub { $minus = 1; -42 } ); + + like( + exception { Foo::Overloaded->new - Foo::Overloaded->new }, + qr/Operation $quote-$quote: no .+ found/, + 'trying to call - on objects fails' + ); + + $meta->add_overloaded_operator( '-' => $minus_impl ); + + ok( + $meta->has_overloaded_operator('-'), + 'has - operator after call to ->add_overloaded_operator' + ); + + is_deeply( + [ sort $meta->get_overload_list ], [ '+', '-' ], + '->get_overload_list returns (+, -)' + ); + + is( + scalar( $meta->get_all_overloaded_operators ), 2, + '->get_all_overloaded_operators returns 2 operators' + ); + + my $minus_overload = $meta->get_overloaded_operator('-'); + isa_ok( + $minus_overload, 'Class::MOP::Overload', + 'object for - overloading' + ); + is( + $minus_overload->operator, '-', + 'operator for overload is -' + ); + is( + $minus_overload->coderef, $minus_impl, + 'coderef for overload matches sub we passed' + ); + is( + $minus_overload->coderef_package, 'main', + 'coderef package for overload is main' + ); + is( + $minus_overload->coderef_name, 'overload_minus', + 'coderef name for overload is overload_minus' + ); + ok( + !$minus_overload->is_anonymous, + 'overload is not anonymous' + ); + is( + $minus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + is( $minus, 0, '- overloading has not been called' ); + is( + Foo::Overloaded->new - Foo::Overloaded->new, -42, + '- overloading returns -42' + ); + is( $minus, 1, '+- overloading was called once' ); + + ok( + !$plus_overload->_is_equal_to($minus_overload), + '_is_equal_to returns false for objects with different properties' + ); + + $meta->remove_overloaded_operator('-'); + + like( + exception { Foo::Overloaded->new - Foo::Overloaded->new }, + qr/Operation $quote-$quote: no .+ found/, + 'trying to call - on objects fails after call to ->remove_overloaded_operator' + ); + } + ); +} + +my $times = 0; +my $divided = 0; +{ + package Foo::OverloadWithMethod; + use Moose; + use overload '*' => 'times'; + + sub times { $times = 1; 'times' } + sub divided { $divided = 1; 'divided' } +} + +{ + my $meta = Foo::OverloadWithMethod->meta; + + subtest( + 'Foo::OverloadWithMethod (overloaded via method)', + sub { + ok( + $meta->is_overloaded, + 'is overloaded' + ); + + ok( + $meta->has_overloaded_operator('*'), + 'overloads *' + ); + ok( + !$meta->has_overloaded_operator('/'), + 'does not overload /' + ); + + is_deeply( + [ $meta->get_overload_list ], ['*'], + '->get_overload_list returns (*)' + ); + + my @overloads = $meta->get_all_overloaded_operators; + is( + scalar(@overloads), 1, + '->get_all_overloaded_operators returns 1 item' + ); + my $times_overload = $overloads[0]; + isa_ok( + $times_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $times_overload->operator, '*', + 'operator for overload is +' + ); + ok( + $times_overload->has_method_name, + 'overload has a method name' + ); + is( + $times_overload->method_name, 'times', + q{method name is 'times'} + ); + ok( + !$times_overload->has_coderef, + 'overload does not have a coderef' + ); + ok( + !$times_overload->has_coderef_package, + 'overload does not have a coderef package' + ); + ok( + !$times_overload->has_coderef_name, + 'overload does not have a coderef name' + ); + ok( + !$times_overload->is_anonymous, + 'overload is not anonymous' + ); + ok( + $times_overload->has_method, + 'overload has a method' + ); + is( + $times_overload->method, $meta->get_method('times'), + '->method returns method object for times method' + ); + is( + $times_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + is( $times, 0, '* overloading has not been called' ); + is( + Foo::OverloadWithMethod->new * Foo::OverloadWithMethod->new, + 'times', + q{* overloading returns 'times'} + ); + is( $times, 1, '* overloading was called once' ); + + my $times_overload2 = $meta->get_overloaded_operator('*'); + + ok( + $times_overload->_is_equal_to($times_overload2), + '_is_equal_to returns true for the exact same object' + ); + + my $times_overload3 = Class::MOP::Overload->new( + operator => '*', + method_name => 'times', + ); + + ok( + $times_overload->_is_equal_to($times_overload3), + '_is_equal_to returns true for object with the same properties' + ); + + like( + exception { + Foo::OverloadWithMethod->new + / Foo::OverloadWithMethod->new + }, + qr{Operation $quote/$quote: no .+ found}, + 'trying to call / on objects fails' + ); + + $meta->add_overloaded_operator( '/' => 'divided' ); + + ok( + $meta->has_overloaded_operator('/'), + 'has / operator after call to ->add_overloaded_operator' + ); + + is_deeply( + [ sort $meta->get_overload_list ], [ '*', '/' ], + '->get_overload_list returns (*, /)' + ); + + is( + scalar( $meta->get_all_overloaded_operators ), 2, + '->get_all_overloaded_operators returns 2 operators' + ); + + my $divided_overload = $meta->get_overloaded_operator('/'); + isa_ok( + $divided_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $divided_overload->operator, '/', + 'operator for overload is /' + ); + is( + $divided_overload->method_name, 'divided', + q{method name is 'divided'} + ); + is( + $divided_overload->method, $meta->get_method('divided'), + '->method returns method object for divided method' + ); + is( + $divided_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + $meta->remove_overloaded_operator('/'); + + like( + exception { + Foo::OverloadWithMethod->new + / Foo::OverloadWithMethod->new + }, + qr{Operation $quote/$quote: no .+ found}, + 'trying to call / on objects fails after call to ->remove_overloaded_operator' + ); + } + ); +} + +{ + package Foo::UnimplementedOverload; + use Moose; + use overload '+' => 'plus'; +} + +{ + my $meta = Foo::UnimplementedOverload->meta; + + subtest( + 'Foo::UnimplementedOverload (overloaded via method that does not exist)', + sub { + ok( + $meta->is_overloaded, + 'is overloaded' + ); + + ok( + $meta->has_overloaded_operator('+'), + 'overloads +' + ); + + my $plus_overload = $meta->get_overloaded_operator('+'); + isa_ok( + $plus_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $plus_overload->operator, '+', + 'operator for overload is +' + ); + ok( + $plus_overload->has_method_name, + 'overload has a method name' + ); + is( + $plus_overload->method_name, 'plus', + q{method name is 'plus'} + ); + ok( + !$plus_overload->has_coderef, + 'overload does not have a coderef' + ); + ok( + !$plus_overload->has_coderef_package, + 'overload does not have a coderef package' + ); + ok( + !$plus_overload->has_coderef_name, + 'overload does not have a coderef name' + ); + ok( + !$plus_overload->is_anonymous, + 'overload is not anonymous' + ); + ok( + !$plus_overload->has_method, + 'overload has no method object' + ); + is( + $plus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + } + ); +} + +done_testing; diff --git a/t/metaclasses/reinitialize.t b/t/metaclasses/reinitialize.t new file mode 100644 index 0000000..2e6020b --- /dev/null +++ b/t/metaclasses/reinitialize.t @@ -0,0 +1,320 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; +use Test::Fatal; + +sub check_meta_sanity { + my ($meta, $class) = @_; + local $Test::Builder::Level = $Test::Builder::Level + 1; + isa_ok($meta, 'Moose::Meta::Class'); + is($meta->name, $class); + ok($meta->has_method('foo')); + isa_ok($meta->get_method('foo'), 'Moose::Meta::Method'); + ok($meta->has_attribute('bar')); + isa_ok($meta->get_attribute('bar'), 'Moose::Meta::Attribute'); + + if ( $meta->name eq 'Foo' ) { + ok($meta->does_role('Role1'), 'does Role1'); + ok($meta->does_role('Role2'), 'does Role2'); + + is_deeply( + [ + map { [ $_->role->name, $_->class->name ] } + sort { $a->role->name cmp $b->role->name } + $meta->role_applications + ], + [ + [ 'Role1|Role2', 'Foo' ], + ], + 'role applications for Role1 and Role2' + ); + } +} + +{ + package Role1; + use Moose::Role; +} + +{ + package Role2; + use Moose::Role; +} + +{ + package Foo; + use Moose; + sub foo {} + with 'Role1', 'Role2'; + has bar => (is => 'ro'); +} + +check_meta_sanity(Foo->meta, 'Foo'); + +Moose::Meta::Class->reinitialize('Foo'); +check_meta_sanity(Foo->meta, 'Foo'); + +{ + package Foo::Role::Method; + use Moose::Role; + + has foo => (is => 'rw'); +} + +{ + package Foo::Role::Attribute; + use Moose::Role; + has oof => (is => 'rw'); +} + +Moose::Util::MetaRole::apply_metaroles( + for => 'Foo', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +check_meta_sanity(Foo->meta, 'Foo'); +does_ok(Foo->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Foo->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +Moose::Meta::Class->reinitialize('Foo'); +check_meta_sanity(Foo->meta, 'Foo'); +does_ok(Foo->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Foo->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +Foo->meta->get_method('foo')->foo('TEST'); +Foo->meta->get_attribute('bar')->oof('TSET'); +is(Foo->meta->get_method('foo')->foo, 'TEST'); +is(Foo->meta->get_attribute('bar')->oof, 'TSET'); +Moose::Meta::Class->reinitialize('Foo'); +check_meta_sanity(Foo->meta, 'Foo'); +is(Foo->meta->get_method('foo')->foo, 'TEST'); +is(Foo->meta->get_attribute('bar')->oof, 'TSET'); + +{ + package Bar::Role::Method; + use Moose::Role; +} + +{ + package Bar::Role::Attribute; + use Moose::Role; +} + +{ + package Bar; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => 'Bar', + class_metaroles => { + method => ['Bar::Role::Method'], + attribute => ['Bar::Role::Attribute'], + }, + ); + sub foo {} + has bar => (is => 'ro'); +} + +check_meta_sanity(Bar->meta, 'Bar'); +does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); + +Moose::Meta::Class->reinitialize('Bar'); +check_meta_sanity(Bar->meta, 'Bar'); +does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); +ok(!Moose::Util::does_role(Bar->meta->get_method('foo'), 'Foo::Role::Method')); +ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Foo::Role::Attribute')); + +Moose::Util::MetaRole::apply_metaroles( + for => 'Bar', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +check_meta_sanity(Bar->meta, 'Bar'); +does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); +does_ok(Bar->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Bar->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +{ + package Bar::Meta::Method; + use Moose; + BEGIN { extends 'Moose::Meta::Method' }; +} + +{ + package Bar::Meta::Attribute; + use Moose; + BEGIN { extends 'Moose::Meta::Attribute' }; +} + +like( exception { + Moose::Meta::Class->reinitialize( + 'Bar', + method_metaclass => 'Bar::Meta::Method', + attribute_metaclass => 'Bar::Meta::Attribute', + ); +}, qr/\QAttribute (class_name) is required/ ); + +{ + package Baz::Meta::Class; + use Moose; + BEGIN { extends 'Moose::Meta::Class' }; + + sub initialize { + my $self = shift; + return $self->SUPER::initialize( + @_, + method_metaclass => 'Bar::Meta::Method', + attribute_metaclass => 'Bar::Meta::Attribute' + ); + } +} + +{ + package Baz; + use Moose -metaclass => 'Baz::Meta::Class'; + sub foo {} + has bar => (is => 'ro'); +} + +check_meta_sanity(Baz->meta, 'Baz'); +isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +Moose::Meta::Class->reinitialize('Baz'); +check_meta_sanity(Baz->meta, 'Baz'); +isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); + +Moose::Util::MetaRole::apply_metaroles( + for => 'Baz', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +check_meta_sanity(Baz->meta, 'Baz'); +isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +does_ok(Baz->meta->get_method('foo'), 'Foo::Role::Method'); +does_ok(Baz->meta->get_attribute('bar'), 'Foo::Role::Attribute'); + +{ + package Baz::Meta::Method; + use Moose; + extends 'Moose::Meta::Method'; +} + +{ + package Baz::Meta::Attribute; + use Moose; + extends 'Moose::Meta::Attribute'; +} + +like( exception { + Moose::Meta::Class->reinitialize( + 'Baz', + method_metaclass => 'Baz::Meta::Method', + attribute_metaclass => 'Baz::Meta::Attribute', + ); +}, qr/\QAttribute (class_name) is required/ ); + +{ + package Quux; + use Moose; + sub foo { } + before foo => sub { }; + has bar => (is => 'ro'); + sub DEMOLISH { } + __PACKAGE__->meta->make_immutable; +} + +ok(Quux->meta->has_method('new')); +isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); +ok(Quux->meta->has_method('meta')); +isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); +ok(Quux->meta->has_method('foo')); +isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +ok(Quux->meta->has_method('bar')); +isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); +ok(Quux->meta->has_method('DESTROY')); +isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); +ok(Quux->meta->has_method('DEMOLISH')); +isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); + +Quux->meta->make_mutable; +Moose::Meta::Class->reinitialize('Quux'); +Quux->meta->make_immutable; + +ok(Quux->meta->has_method('new')); +isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); +ok(Quux->meta->has_method('meta')); +isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); +ok(Quux->meta->has_method('foo')); +isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +ok(Quux->meta->has_method('bar')); +isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); +ok(Quux->meta->has_method('DESTROY')); +isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); +ok(Quux->meta->has_method('DEMOLISH')); +isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); + +Quux->meta->make_mutable; +Moose::Util::MetaRole::apply_metaroles( + for => 'Quux', + class_metaroles => { + method => ['Foo::Role::Method'], + attribute => ['Foo::Role::Attribute'], + }, +); +Quux->meta->make_immutable; + +ok(Quux->meta->has_method('new')); +isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); +{ local $TODO = "constructor methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('new'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('meta')); +isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); +{ local $TODO = "meta methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('meta'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('foo')); +isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +{ local $TODO = "modified methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('foo'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('bar')); +isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); +{ local $TODO = "accessor methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('bar'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('DESTROY')); +isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); +{ local $TODO = "destructor methods don't get metaroles yet"; +does_ok(Quux->meta->get_method('DESTROY'), 'Foo::Role::Method'); +} +ok(Quux->meta->has_method('DEMOLISH')); +isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); +does_ok(Quux->meta->get_method('DEMOLISH'), 'Foo::Role::Method'); + +{ + package Role3; + use Moose::Role; + with 'Role1', 'Role2'; +} + +ok( Role3->meta->does_role('Role1'), 'Role3 does Role1' ); +ok( Role3->meta->does_role('Role2'), 'Role3 does Role2' ); + +Moose::Meta::Role->reinitialize('Role3'); + +ok( Role3->meta->does_role('Role1'), 'Role3 does Role1 after reinitialize' ); +ok( Role3->meta->does_role('Role2'), 'Role3 does Role2 after reinitialize' ); + +done_testing; diff --git a/t/metaclasses/use_base_of_moose.t b/t/metaclasses/use_base_of_moose.t new file mode 100644 index 0000000..fdcd601 --- /dev/null +++ b/t/metaclasses/use_base_of_moose.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::More; + +{ + package NoOpTrait; + use Moose::Role; +} + +{ + package Parent; + use Moose -traits => 'NoOpTrait'; + + has attr => ( + is => 'rw', + isa => 'Str', + ); +} + +{ + package Child; + use parent -norequire => '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"); + +done_testing; |