From 636f22f307ff0dc94a2c2ec23d49c872ecddbc02 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Mon, 19 Jul 2010 19:10:14 -0500 Subject: initial implementation --- lib/MooseX/Exporter/Easy.pm | 72 +++ lib/MooseX/Exporter/Easy/Meta/Role/Package.pm | 128 +++++ t/lib/MyExporter.pm | 21 + t/lib/MyMetaclassRole.pm | 4 + t/moose/007_always_strict_warnings.t | 71 +++ t/moose/012_moose_exporter.t | 371 ++++++++++++++ t/moose/015_metarole.t | 685 ++++++++++++++++++++++++++ t/moose/021_export_with_prototype.t | 22 + t/moose/023_easy_init_meta.t | 126 +++++ t/moose/030_metarole_combination.t | 240 +++++++++ t/moose/moose_cookbook_extending_recipe2.t | 65 +++ t/moose/moose_cookbook_extending_recipe3.t | 77 +++ t/moose/moose_cookbook_extending_recipe4.t | 67 +++ 13 files changed, 1949 insertions(+) create mode 100644 lib/MooseX/Exporter/Easy/Meta/Role/Package.pm create mode 100644 t/lib/MyExporter.pm create mode 100644 t/lib/MyMetaclassRole.pm create mode 100644 t/moose/007_always_strict_warnings.t create mode 100644 t/moose/012_moose_exporter.t create mode 100644 t/moose/015_metarole.t create mode 100644 t/moose/021_export_with_prototype.t create mode 100644 t/moose/023_easy_init_meta.t create mode 100644 t/moose/030_metarole_combination.t create mode 100644 t/moose/moose_cookbook_extending_recipe2.t create mode 100644 t/moose/moose_cookbook_extending_recipe3.t create mode 100644 t/moose/moose_cookbook_extending_recipe4.t diff --git a/lib/MooseX/Exporter/Easy.pm b/lib/MooseX/Exporter/Easy.pm index e69de29..f6d4d5b 100644 --- a/lib/MooseX/Exporter/Easy.pm +++ b/lib/MooseX/Exporter/Easy.pm @@ -0,0 +1,72 @@ +package MooseX::Exporter::Easy; +use Moose (); +use Moose::Exporter; + +use Carp qw(confess); +use Scalar::Util qw(blessed); + +Moose::Exporter->setup_import_methods( + with_meta => [qw(with_meta as_is also + class_metaroles role_metaroles base_class_roles + export)], +); + +sub with_meta { + my ($meta, $name, $sub) = @_; + confess "with_meta requires a name and a sub to export" + unless defined($name) && defined($sub) && ref($sub) eq 'CODE'; + $meta->add_with_meta($name, $sub); +} + +sub as_is { + my ($meta, $name, $sub) = @_; + confess "as_is requires a name and a sub to export" + unless defined($name) && defined($sub) && ref($sub) eq 'CODE'; + $meta->add_as_is($name, $sub); +} + +sub also { + my ($meta, @also) = @_; + $meta->add_also(@also); +} + +sub class_metaroles { + my ($meta, $roles) = @_; + $meta->class_metaroles($roles); +} + +sub role_metaroles { + my ($meta, $roles) = @_; + $meta->role_metaroles($roles); +} + +sub base_class_roles { + my ($meta, @roles) = @_; + $meta->add_base_class_roles(@roles); +} + +sub export { + my ($meta) = @_; + $meta->setup_exporter; +} + +# move this into Moose::Util? +sub with_traits { + my ($class, @roles) = @_; + return Moose::Meta::Class->create_anon_class( + superclasses => [$class], + roles => \@roles, + cache => 1, + )->name; +} + +sub init_meta { + my $package = shift; + my %opts = @_; + my $meta_name = blessed(Class::MOP::class_of($opts{for_class})) + || 'Class::MOP::Package'; + $meta_name = with_traits($meta_name, 'MooseX::Exporter::Easy::Meta::Role::Package'); + my $meta = $meta_name->reinitialize($opts{for_class}); +} + +1; diff --git a/lib/MooseX/Exporter/Easy/Meta/Role/Package.pm b/lib/MooseX/Exporter/Easy/Meta/Role/Package.pm new file mode 100644 index 0000000..755b50a --- /dev/null +++ b/lib/MooseX/Exporter/Easy/Meta/Role/Package.pm @@ -0,0 +1,128 @@ +package MooseX::Exporter::Easy::Meta::Role::Package; +use Moose::Role; + +has with_meta => ( + traits => ['Array'], + isa => 'ArrayRef[Str]', + default => sub { [] }, + handles => { + with_meta => 'elements', + _add_with_meta => 'push', + } +); + +sub add_with_meta { + my $self = shift; + my ($name, $sub) = @_; + $self->add_package_symbol('&' . $name, $sub); + $self->_add_with_meta($name); +} + +has as_is => ( + traits => ['Array'], + isa => 'ArrayRef[Str]', + default => sub { [] }, + handles => { + as_is => 'elements', + _add_as_is => 'push', + } +); + +sub add_as_is { + my $self = shift; + my ($name, $sub) = @_; + $self->add_package_symbol('&' . $name, $sub); + $self->_add_as_is($name); +} + +has also => ( + traits => ['Array'], + isa => 'ArrayRef[Str]', + default => sub { [] }, + handles => { + also => 'elements', + add_also => 'push', + } +); + +has class_metaroles => ( + is => 'rw', + isa => 'HashRef[ArrayRef[Str]]', + predicate => 'has_class_metaroles', +); + +has role_metaroles => ( + is => 'rw', + isa => 'HashRef[ArrayRef[Str]]', + predicate => 'has_role_metaroles', +); + +has base_class_roles => ( + traits => ['Array'], + isa => 'ArrayRef[Str]', + default => sub { [] }, + handles => { + base_class_roles => 'elements', + add_base_class_roles => 'push', + has_base_class_roles => 'count', + } +); + +sub setup_exporter { + my $self = shift;; + + my ($import, $unimport, $init_meta) = Moose::Exporter->build_import_methods( + exporting_package => $self->name, + with_meta => [$self->with_meta], + as_is => [$self->as_is], + also => [$self->also], + $self->has_class_metaroles + ? (class_metaroles => $self->class_metaroles) + : (), + $self->has_role_metaroles + ? (role_metaroles => $self->role_metaroles) + : (), + $self->has_base_class_roles + ? (base_class_roles => [$self->base_class_roles]) + : (), + ); + + $self->add_package_symbol('&import' => + ($self->has_package_symbol('&import_extra') + ? sub { + my ($package, @args) = @_; + $package->import_extra(@args); + goto $import; + } + : $import) + ); + $self->add_package_symbol('&unimport' => + ($self->has_package_symbol('&unimport_extra') + ? sub { + my ($package, @args) = @_; + $package->unimport_extra(@args); + goto $unimport; + } + : $unimport) + ); + if ($init_meta) { + $self->add_package_symbol('&init_meta' => + ($self->has_package_symbol('&init_meta_extra') + ? sub { + my ($package, @args) = @_; + $package->init_meta_extra(@args); + goto $init_meta; + } + : $init_meta) + ); + } + elsif ($self->has_package_symbol('&init_meta_extra')) { + $self->add_package_symbol('&init_meta' => + sub { goto $_[0]->can('init_meta_extra') } + ); + } +} + +no Moose::Role; + +1; diff --git a/t/lib/MyExporter.pm b/t/lib/MyExporter.pm new file mode 100644 index 0000000..a29fff0 --- /dev/null +++ b/t/lib/MyExporter.pm @@ -0,0 +1,21 @@ + + +package MyExporter; +use MooseX::Exporter::Easy; +use Test::More; + +with_meta with_prototype => sub (&) { + my ($meta, $code) = @_; + isa_ok($code, 'CODE', 'with_prototype received a coderef'); + $code->(); +}; + +as_is as_is_prototype => sub (&) { + my ($code) = @_; + isa_ok($code, 'CODE', 'as_is_prototype received a coderef'); + $code->(); +}; + +export; + +1; diff --git a/t/lib/MyMetaclassRole.pm b/t/lib/MyMetaclassRole.pm new file mode 100644 index 0000000..362265a --- /dev/null +++ b/t/lib/MyMetaclassRole.pm @@ -0,0 +1,4 @@ +package MyMetaclassRole; +use Moose::Role; + +1; diff --git a/t/moose/007_always_strict_warnings.t b/t/moose/007_always_strict_warnings.t new file mode 100644 index 0000000..c09e9d7 --- /dev/null +++ b/t/moose/007_always_strict_warnings.t @@ -0,0 +1,71 @@ +#!/usr/bin/perl + +use Test::More; + +# for classes ... +{ + package Foo; + use Moose; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} + +# and for roles ... +{ + package Bar; + use Moose::Role; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} + +# and for exporters +{ + package Bar; + use MooseX::Exporter::Easy; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} + +done_testing; diff --git a/t/moose/012_moose_exporter.t b/t/moose/012_moose_exporter.t new file mode 100644 index 0000000..937649e --- /dev/null +++ b/t/moose/012_moose_exporter.t @@ -0,0 +1,371 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Exception; +BEGIN { + eval "use Test::Output;"; + plan skip_all => "Test::Output is required for this test" if $@; +} + + +{ + 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 (); + use MooseX::Exporter::Easy; + also 'Moose'; + export; +} + +{ + 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 (); + use MooseX::Exporter::Easy; + + also 'Moose'; + + with_meta wrapped1 => sub { + my $meta = shift; + return $meta->name . ' called wrapped1'; + }; + + export; +} + +{ + 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 (); + use MooseX::Exporter::Easy; + + also 'MooseX::Sugar'; + + with_meta wrapped2 => sub { + my $meta = shift; + return $meta->name . ' called wrapped2'; + }; + + as_is as_is1 => sub { + return 'as_is1'; + }; + + export; +} + +{ + 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 (); + use MooseX::Exporter::Easy; + + also 'Moose'; + + sub init_meta_extra { + shift; + return Moose->init_meta( @_, + metaclass => 'My::Metaclass', + base_class => 'My::Object', + ); + } + + export; +} + +{ + package NewMeta; + + HasInitMeta->import(); +} + +{ + isa_ok( NewMeta->meta(), 'My::Metaclass' ); + isa_ok( NewMeta->new(), 'My::Object' ); +} + +{ + package MooseX::CircularAlso; + + use Moose (); + use MooseX::Exporter::Easy; + also 'Moose', 'MooseX::CircularAlso'; + + ::dies_ok( + sub { export }, + 'a circular reference in also dies with an error' + ); + + ::like( + $@, + qr/\QCircular reference in 'also' parameter to Moose::Exporter between MooseX::CircularAlso and MooseX::CircularAlso/, + 'got the expected error from circular reference in also' + ); +} + +{ + package MooseX::NoAlso; + + use Moose (); + use MooseX::Exporter::Easy; + + also 'NoSuchThing'; + + ::dies_ok( + sub { export }, + 'a package which does not use Moose::Exporter in also dies with an error' + ); + + ::like( + $@, + qr/\QPackage in also (NoSuchThing) does not seem to use Moose::Exporter (is it loaded?) at /, + 'got the expected error from a reference in also to a package which is not loaded' + ); +} + +{ + package MooseX::NotExporter; + + use Moose (); + use MooseX::Exporter::Easy; + + also 'Moose::Meta::Method'; + + ::dies_ok( + sub { export }, + 'a package which does not use Moose::Exporter in also dies with an error' + ); + + ::like( + $@, + qr/\QPackage in also (Moose::Meta::Method) does not seem to use Moose::Exporter at /, + 'got the expected error from a reference in also to a package which does not use Moose::Exporter' + ); +} + +{ + package MooseX::OverridingSugar; + + use Moose (); + use MooseX::Exporter::Easy; + + also 'Moose'; + + with_meta has => sub { + my $meta = shift; + return $meta->name . ' called has'; + }; + + export; +} + +{ + 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( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' ); + ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' ); +} + +{ + package NonExistentExport; + + use Moose (); + use MooseX::Exporter::Easy; + + also 'Moose'; + + ::throws_ok { + with_meta 'does_not_exist'; + } qr/with_meta requires a name and a sub to export/, + "dies when a function to export isn't passed"; + + export; +} + +{ + package WantsNonExistentExport; + + NonExistentExport->import; + + ::ok(!__PACKAGE__->can('does_not_exist'), + "undefined subs do not get exported"); +} + +{ + package AllOptions; + use Moose (); + use MooseX::Exporter::Easy; + + also 'Moose'; + + as_is as_is1 => sub {2}; + + with_meta with_meta1 => sub { + return @_; + }; + + with_meta with_meta2 => sub (&) { + return @_; + }; + + export; +} + +{ + package UseAllOptions; + + AllOptions->import(); +} + +{ + can_ok( 'UseAllOptions', $_ ) + for qw( with_meta1 with_meta2 as_is1 ); + + { + 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_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 as_is1 ); +} + +done_testing; diff --git a/t/moose/015_metarole.t b/t/moose/015_metarole.t new file mode 100644 index 0000000..dc8e7d9 --- /dev/null +++ b/t/moose/015_metarole.t @@ -0,0 +1,685 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use lib 't/lib', 'lib'; + +use Test::More; +use Test::Exception; + +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 MooseX::Exporter::Easy; + + also 'Moose'; + + sub init_meta_extra { + shift; + my %p = @_; + + Moose->init_meta( %p, metaclass => 'My::Meta::Class' ); + } + + export; +} + +{ + 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 MooseX::Exporter::Easy; + + also 'Moose'; + + sub init_meta_extra { + shift; + my %p = @_; + + Moose->init_meta( + %p, + metaclass => 'My::Meta::Class2', + base_class => 'My::Object', + ); + } + + export; +} + +{ + 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 base '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; + + use MooseX::Exporter::Easy; + + also 'Moose'; + + sub init_meta_extra { + shift; + my %p = @_; + Moose->init_meta(%p); + return Moose::Util::MetaRole::apply_metaroles( + for_class => $p{for_class}, + # Causes us to recurse through init_meta, as we have to + # load MyMetaclassRole from disk. + metaclass_roles => [qw/MyMetaclassRole/], + ); + } + + export; +} + +lives_ok { + package UsesExportedMoose; + ExportsMoose->import; +} 'import module which loads a role from disk during init_meta'; + +{ + package Foo::Meta::Role; + + use Moose::Role; +} + +{ + package Foo::Role; + + use MooseX::Exporter::Easy; + + also 'Moose::Role'; + + sub init_meta_extra { + shift; + my %p = @_; + + Moose::Role->init_meta(%p); + + return Moose::Util::MetaRole::apply_metaroles( + for => $p{for_class}, + role_metaroles => { method => ['Foo::Meta::Role'] }, + ); + } + + export; +} + +{ + 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' + ); +} + +done_testing; diff --git a/t/moose/021_export_with_prototype.t b/t/moose/021_export_with_prototype.t new file mode 100644 index 0000000..6c8f5e2 --- /dev/null +++ b/t/moose/021_export_with_prototype.t @@ -0,0 +1,22 @@ +use lib "t/lib"; +package MyExporter::User; +use MyExporter; + +use Test::More; +use Test::Exception; + +lives_and { + with_prototype { + my $caller = caller(0); + is($caller, 'MyExporter', "With_caller prototype code gets called from MyMooseX"); + }; +} "check function with prototype"; + +lives_and { + as_is_prototype { + my $caller = caller(0); + is($caller, 'MyExporter', "As-is prototype code gets called from MyMooseX"); + }; +} "check function with prototype"; + +done_testing; diff --git a/t/moose/023_easy_init_meta.t b/t/moose/023_easy_init_meta.t new file mode 100644 index 0000000..b54cd14 --- /dev/null +++ b/t/moose/023_easy_init_meta.t @@ -0,0 +1,126 @@ +#!/usr/bin/perl + +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 MooseX::Exporter::Easy; + + class_metaroles { + class => ['Foo::Trait::Class'], + attribute => ['Foo::Trait::Attribute'], + }; + role_metaroles { + role => ['Foo::Trait::Class'], + }; + base_class_roles 'Foo::Role::Base'; + + export; +} + +{ + 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 MooseX::Exporter::Easy; + + also 'Moose'; + + class_metaroles { + class => ['Foo::Trait::Class'], + attribute => ['Foo::Trait::Attribute'], + }; + base_class_roles 'Foo::Role::Base'; + + sub init_meta_extra { + my $package = shift; + my %options = @_; + ::pass('custom init_meta was called'); + Moose->init_meta(%options); + } + + export; +} + +{ + 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 MooseX::Exporter::Easy; + + also 'Moose::Role'; + + role_metaroles { + role => ['Foo::Trait::Class'], + attribute => ['Foo::Trait::Attribute'], + }; + + sub init_meta_extra { + my $package = shift; + my %options = @_; + ::pass('custom init_meta was called'); + Moose::Role->init_meta(%options); + } + + export; +} + +{ + 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/moose/030_metarole_combination.t b/t/moose/030_metarole_combination.t new file mode 100644 index 0000000..a045df2 --- /dev/null +++ b/t/moose/030_metarole_combination.t @@ -0,0 +1,240 @@ +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; + use MooseX::Exporter::Easy; + + also 'Moose::Role'; + + sub init_meta_extra { + my ( $self, %options ) = @_; + return Moose::Util::MetaRole::apply_metaroles( + for_class => 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'], + }, + ); + } + + export; +} + +{ + 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/moose/moose_cookbook_extending_recipe2.t b/t/moose/moose_cookbook_extending_recipe2.t new file mode 100644 index 0000000..763586e --- /dev/null +++ b/t/moose/moose_cookbook_extending_recipe2.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Exception; +$| = 1; + + + +# =begin testing SETUP +BEGIN { + eval 'use Test::Output;'; + if ($@) { + diag 'Test::Output is required for this test'; + ok(1); + exit 0; + } +} + + + +# =begin testing SETUP +{ + + package MooseX::Debugging; + + use MooseX::Exporter::Easy; + + base_class_roles 'MooseX::Debugging::Role::Object'; + + export; + + package MooseX::Debugging::Role::Object; + + use Moose::Role; + + after 'BUILDALL' => sub { + my $self = shift; + + warn "Made a new " . ( ref $self ) . " object\n"; + }; +} + + + +# =begin testing +{ +{ + package Debugged; + + use Moose; + MooseX::Debugging->import; +} + +stderr_is( + sub { Debugged->new }, + "Made a new Debugged object\n", + 'got expected output from debugging role' +); +} + + + + +1; diff --git a/t/moose/moose_cookbook_extending_recipe3.t b/t/moose/moose_cookbook_extending_recipe3.t new file mode 100644 index 0000000..98ef077 --- /dev/null +++ b/t/moose/moose_cookbook_extending_recipe3.t @@ -0,0 +1,77 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Exception; +$| = 1; + + + +# =begin testing SETUP +BEGIN { + eval 'use Test::Output;'; + if ($@) { + diag 'Test::Output is required for this test'; + ok(1); + exit 0; + } +} + + + +# =begin testing SETUP +{ + + package MyApp::Base; + use Moose; + + extends 'Moose::Object'; + + before 'new' => sub { warn "Making a new " . $_[0] }; + + no Moose; + + package MyApp::UseMyBase; + use Moose (); + use MooseX::Exporter::Easy; + + also 'Moose'; + + sub init_meta_extra { + shift; + return Moose->init_meta( @_, base_class => 'MyApp::Base' ); + } + + export; +} + + + +# =begin testing +{ +{ + package Foo; + + MyApp::UseMyBase->import; + + has( 'size' => ( is => 'rw' ) ); +} + +ok( Foo->isa('MyApp::Base'), 'Foo isa MyApp::Base' ); + +ok( Foo->can('size'), 'Foo has a size method' ); + +my $foo; +stderr_like( + sub { $foo = Foo->new( size => 2 ) }, + qr/^Making a new Foo/, + 'got expected warning when calling Foo->new' +); + +is( $foo->size(), 2, '$foo->size is 2' ); +} + + + + +1; diff --git a/t/moose/moose_cookbook_extending_recipe4.t b/t/moose/moose_cookbook_extending_recipe4.t new file mode 100644 index 0000000..1a41093 --- /dev/null +++ b/t/moose/moose_cookbook_extending_recipe4.t @@ -0,0 +1,67 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Exception; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Mooseish; + + use Moose (); + use MooseX::Exporter::Easy; + + also 'Moose'; + + sub init_meta_extra { + shift; + return Moose->init_meta( @_, metaclass => 'MyApp::Meta::Class' ); + } + + with_meta has_table => sub { + my $meta = shift; + $meta->table(shift); + }; + + export; + + package MyApp::Meta::Class; + use Moose; + + extends 'Moose::Meta::Class'; + + has 'table' => ( is => 'rw' ); +} + + + +# =begin testing +{ +{ + package MyApp::User; + + MyApp::Mooseish->import; + + has_table( 'User' ); + + has( 'username' => ( is => 'ro' ) ); + has( 'password' => ( is => 'ro' ) ); + + sub login { } +} + +isa_ok( MyApp::User->meta, 'MyApp::Meta::Class' ); +is( MyApp::User->meta->table, 'User', + 'MyApp::User->meta->table returns User' ); +ok( MyApp::User->can('username'), + 'MyApp::User has username method' ); +} + + + + +1; -- cgit v1.2.3