From: Jesse Luehrs Date: Sun, 19 Jun 2011 06:14:30 +0000 (-0500) Subject: fix tests for the deprecation stuff X-Git-Tag: 2.0103~26 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=680b7c2739d9bc952a21805e16a8060c9f6f8283;p=gitmo%2FMoose.git fix tests for the deprecation stuff --- diff --git a/t/basics/deprecations.t b/t/basics/deprecations.t index cb2eaf9..9a8a4c0 100644 --- a/t/basics/deprecations.t +++ b/t/basics/deprecations.t @@ -45,20 +45,6 @@ use Test::Requires { ::stderr_like{ Foo->new->bar } qr{\QThe bar method in the Foo class was automatically created by the native delegation trait for the bar attribute. This "default is" feature is deprecated. Explicitly set "is" or define accessor names to avoid this at $0 line}, 'calling a reader on a method created by a _default_is warns'; - - ::stderr_like{ with 'Role' => - { excludes => ['thing'], alias => { thing => 'thing2' } }; - } - qr/\QThe alias and excludes options for role application have been renamed -alias and -excludes (Foo is consuming Role - do you need to upgrade Foo?)/, - 'passing excludes or alias with a leading dash warns'; - ::ok( - !Foo->meta->has_method('thing'), - 'thing method is excluded from role application' - ); - ::ok( - Foo->meta->has_method('thing2'), - 'thing2 method is created as alias in role application' - ); } ), undef ); } diff --git a/t/cmop/attribute_introspection.t b/t/cmop/attribute_introspection.t index 86d0c57..761fd95 100644 --- a/t/cmop/attribute_introspection.t +++ b/t/cmop/attribute_introspection.t @@ -58,7 +58,6 @@ use Class::MOP; associated_methods associate_method - process_accessors _process_accessors _accessor_description install_accessors diff --git a/t/cmop/deprecated.t b/t/cmop/deprecated.t index 471fb4a..07a8cf9 100644 --- a/t/cmop/deprecated.t +++ b/t/cmop/deprecated.t @@ -8,66 +8,6 @@ use Carp; $SIG{__WARN__} = \&croak; -{ - package Foo; - - ::like( ::exception { - Class::MOP::in_global_destruction(); - }, qr/\b deprecated \b/xmsi, 'Class::MOP::in_global_destruction is deprecated' ); -} - -{ - package Bar; - - use Class::MOP::Deprecated -api_version => 0.93; - - ::like( ::exception { - Class::MOP::in_global_destruction(); - }, qr/\b deprecated \b/xmsi, 'Class::MOP::in_global_destruction is deprecated with 0.93 compatibility' ); -} - -{ - package Baz; - - use Class::MOP::Deprecated -api_version => 0.92; - - ::is( ::exception { - Class::MOP::in_global_destruction(); - }, undef, 'Class::MOP::in_global_destruction is not deprecated with 0.92 compatibility' ); -} - -{ - package Foo2; - - use metaclass; - - ::like( ::exception { Foo2->meta->get_attribute_map }, qr/\Qget_attribute_map method has been deprecated/, 'get_attribute_map is deprecated' ); -} - -{ - package Quux; - - use Class::MOP::Deprecated -api_version => 0.92; - use Scalar::Util qw( blessed ); - - use metaclass; - - sub foo {42} - - Quux->meta->add_method( bar => sub {84} ); - - my $map = Quux->meta->get_method_map; - my @method_objects = grep { blessed($_) } values %{$map}; - - ::is( - scalar @method_objects, 3, - 'get_method_map still returns all values as method object' - ); - ::is_deeply( - [ sort keys %{$map} ], - [qw( bar foo meta )], - 'get_method_map returns expected methods' - ); -} +pass("nothing for now..."); done_testing; diff --git a/t/cmop/instance.t b/t/cmop/instance.t index 5ab6a55..7fcd551 100644 --- a/t/cmop/instance.t +++ b/t/cmop/instance.t @@ -12,7 +12,6 @@ can_ok( "Class::MOP::Instance", $_ ) for qw/ new create_instance - bless_instance_structure get_all_slots diff --git a/t/cmop/self_introspection.t b/t/cmop/self_introspection.t index 7fd0933..c735f74 100644 --- a/t/cmop/self_introspection.t +++ b/t/cmop/self_introspection.t @@ -38,8 +38,6 @@ my @class_mop_package_methods = qw( _package_stash - get_method_map - DESTROY ); @@ -67,7 +65,7 @@ my @class_mop_class_methods = qw( _inline_create_instance _inline_rebless_instance _inline_get_mop_slot _inline_set_mop_slot _inline_clear_mop_slot - create_meta_instance _create_meta_instance + _create_meta_instance new_object clone_object _inline_new_object _inline_default_value _inline_preserve_weak_metaclasses _inline_slot_initializer _inline_extra_init _inline_fallback_constructor @@ -75,12 +73,12 @@ my @class_mop_class_methods = qw( _inline_init_attr_from_constructor _inline_init_attr_from_default _generate_fallback_constructor _eval_environment - construct_instance _construct_instance - construct_class_instance _construct_class_instance - clone_instance _clone_instance + _construct_instance + _construct_class_instance + _clone_instance rebless_instance rebless_instance_back rebless_instance_away _force_rebless_instance _fixup_attributes_after_rebless - check_metaclass_compatibility _check_metaclass_compatibility + _check_metaclass_compatibility _check_class_metaclass_compatibility _check_single_metaclass_compatibility _class_metaclass_is_compatible _single_metaclass_is_compatible _fix_metaclass_incompatibility _fix_class_metaclass_incompatibility @@ -99,7 +97,7 @@ my @class_mop_class_methods = qw( superclasses subclasses direct_subclasses class_precedence_list linearized_isa _superclasses_updated _superclass_metas - alias_method get_all_method_names get_all_methods compute_all_applicable_methods + get_all_method_names get_all_methods find_method_by_name find_all_methods_by_name find_next_method_by_name add_before_method_modifier add_after_method_modifier add_around_method_modifier @@ -110,9 +108,6 @@ my @class_mop_class_methods = qw( find_attribute_by_name get_all_attributes - compute_all_applicable_attributes - get_attribute_map - is_mutable is_immutable make_mutable make_immutable _initialize_immutable _install_inlined_code _inlined_methods _add_inlined_method _inline_accessors _inline_constructor diff --git a/t/examples/example_Protomoose.t b/t/examples/example_Protomoose.t index dd98da9..5a18445 100644 --- a/t/examples/example_Protomoose.t +++ b/t/examples/example_Protomoose.t @@ -141,7 +141,7 @@ Well cause merlyn asked if it could :) ); } - around 'construct_instance' => sub { + around '_construct_instance' => sub { my $next = shift; my $self = shift; # NOTE: diff --git a/t/metaclasses/extending_and_embedding_back_compat.t b/t/metaclasses/extending_and_embedding_back_compat.t deleted file mode 100644 index c7a14eb..0000000 --- a/t/metaclasses/extending_and_embedding_back_compat.t +++ /dev/null @@ -1,55 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::More; - - -BEGIN { - package MyFramework::Base; - use Moose; - - package MyFramework::Meta::Base; - use Moose; - - extends 'Moose::Meta::Class'; - - package MyFramework; - use Moose; - use Moose::Deprecated -api_version => '0.55'; - - sub import { - my $CALLER = caller(); - - strict->import; - warnings->import; - - return if $CALLER eq 'main'; - Moose::init_meta( $CALLER, 'MyFramework::Base', 'MyFramework::Meta::Base' ); - Moose->import({ into => $CALLER }); - - return 1; - } -} - -{ - package MyClass; - BEGIN { MyFramework->import } - - has 'foo' => (is => 'rw'); -} - -can_ok( 'MyClass', 'meta' ); - -isa_ok(MyClass->meta, 'MyFramework::Meta::Base'); -isa_ok(MyClass->meta, 'Moose::Meta::Class'); - -my $obj = MyClass->new(foo => 10); -isa_ok($obj, 'MyClass'); -isa_ok($obj, 'MyFramework::Base'); -isa_ok($obj, 'Moose::Object'); - -is($obj->foo, 10, '... got the right value'); - -done_testing; diff --git a/t/metaclasses/metarole_backcompat.t b/t/metaclasses/metarole_backcompat.t deleted file mode 100644 index 82462c1..0000000 --- a/t/metaclasses/metarole_backcompat.t +++ /dev/null @@ -1,671 +0,0 @@ -#!/usr/bin/perl - -# This is a copy of 015_metarole.t taken on 01/01/2010. It provides a -# comprehensive test of backwards compatibility in the MetaRole API. - -use strict; -use warnings; - -use lib 't/lib', 'lib'; - -use Test::More; -use Test::Fatal; - -use Moose::Util::MetaRole; - -{ - no warnings 'redefine'; - *Moose::Deprecated::deprecated = sub { return }; -} - -{ - 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_metaclass_roles( - for_class => My::Class->meta, - metaclass_roles => ['Role::Foo'], - ); - - ok( My::Class->meta()->meta()->does_role('Role::Foo'), - 'apply Role::Foo to My::Class->meta()' ); - is( My::Class->meta()->foo(), 10, - '... and call foo() on that meta object' ); -} - -{ - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class', - attribute_metaclass_roles => ['Role::Foo'], - ); - - ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), - q{apply Role::Foo to My::Class->meta()'s attribute metaclass} ); - ok( My::Class->meta()->meta()->does_role('Role::Foo'), - '... My::Class->meta() still does Role::Foo' ); - - My::Class->meta()->add_attribute( 'size', is => 'ro' ); - is( My::Class->meta()->get_attribute('size')->foo(), 10, - '... call foo() on an attribute metaclass object' ); -} - -{ - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class', - method_metaclass_roles => ['Role::Foo'], - ); - - ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), - q{apply Role::Foo to My::Class->meta()'s method metaclass} ); - ok( My::Class->meta()->meta()->does_role('Role::Foo'), - '... My::Class->meta() still does Role::Foo' ); - ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), - q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); - - My::Class->meta()->add_method( 'bar' => sub { 'bar' } ); - is( My::Class->meta()->get_method('bar')->foo(), 10, - '... call foo() on a method metaclass object' ); -} - -{ - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class', - wrapped_method_metaclass_roles => ['Role::Foo'], - ); - - ok( My::Class->meta()->wrapped_method_metaclass()->meta()->does_role('Role::Foo'), - q{apply Role::Foo to My::Class->meta()'s wrapped method metaclass} ); - ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), - '... My::Class->meta() still does Role::Foo' ); - ok( My::Class->meta()->meta()->does_role('Role::Foo'), - '... My::Class->meta() still does Role::Foo' ); - ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), - q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); - - My::Class->meta()->add_after_method_modifier( 'bar' => sub { 'bar' } ); - is( My::Class->meta()->get_method('bar')->foo(), 10, - '... call foo() on a wrapped method metaclass object' ); -} - -{ - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class', - instance_metaclass_roles => ['Role::Foo'], - ); - - ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), - q{apply Role::Foo to My::Class->meta()'s instance metaclass} ); - ok( My::Class->meta()->meta()->does_role('Role::Foo'), - '... My::Class->meta() still does Role::Foo' ); - ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), - q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); - ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), - q{... My::Class->meta()'s method metaclass still does Role::Foo} ); - - is( My::Class->meta()->get_meta_instance()->foo(), 10, - '... call foo() on an instance metaclass object' ); -} - -{ - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class', - constructor_class_roles => ['Role::Foo'], - ); - - ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'), - q{apply Role::Foo to My::Class->meta()'s constructor class} ); - ok( My::Class->meta()->meta()->does_role('Role::Foo'), - '... My::Class->meta() still does Role::Foo' ); - ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), - q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); - ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), - q{... My::Class->meta()'s method metaclass still does Role::Foo} ); - ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), - q{... My::Class->meta()'s instance metaclass still does Role::Foo} ); - - # Actually instantiating the constructor class is too freaking hard! - ok( My::Class->meta()->constructor_class()->can('foo'), - '... constructor class has a foo method' ); -} - -{ - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class', - destructor_class_roles => ['Role::Foo'], - ); - - ok( My::Class->meta()->destructor_class()->meta()->does_role('Role::Foo'), - q{apply Role::Foo to My::Class->meta()'s destructor class} ); - ok( My::Class->meta()->meta()->does_role('Role::Foo'), - '... My::Class->meta() still does Role::Foo' ); - ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), - q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); - ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), - q{... My::Class->meta()'s method metaclass still does Role::Foo} ); - ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), - q{... My::Class->meta()'s instance metaclass still does Role::Foo} ); - ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'), - q{... My::Class->meta()'s constructor class still does Role::Foo} ); - - # same problem as the constructor class - ok( My::Class->meta()->destructor_class()->can('foo'), - '... destructor class has a foo method' ); -} - -{ - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Role', - application_to_class_class_roles => ['Role::Foo'], - ); - - ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), - q{apply Role::Foo to My::Role->meta's application_to_class class} ); - - is( My::Role->meta->application_to_class_class->new->foo, 10, - q{... call foo() on an application_to_class instance} ); -} - -{ - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Role', - application_to_role_class_roles => ['Role::Foo'], - ); - - ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'), - q{apply Role::Foo to My::Role->meta's application_to_role class} ); - ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), - q{... My::Role->meta's application_to_class class still does Role::Foo} ); - - is( My::Role->meta->application_to_role_class->new->foo, 10, - q{... call foo() on an application_to_role instance} ); -} - -{ - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Role', - application_to_instance_class_roles => ['Role::Foo'], - ); - - ok( My::Role->meta->application_to_instance_class->meta->does_role('Role::Foo'), - q{apply Role::Foo to My::Role->meta's application_to_instance class} ); - ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'), - q{... My::Role->meta's application_to_role class still does Role::Foo} ); - ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), - q{... My::Role->meta's application_to_class class still does Role::Foo} ); - - is( My::Role->meta->application_to_instance_class->new->foo, 10, - q{... call foo() on an application_to_instance instance} ); -} - -{ - Moose::Util::MetaRole::apply_base_class_roles( - for_class => 'My::Class', - roles => ['Role::Foo'], - ); - - ok( My::Class->meta()->does_role('Role::Foo'), - 'apply Role::Foo to My::Class base class' ); - is( My::Class->new()->foo(), 10, - '... call foo() on a My::Class object' ); -} - -{ - package My::Class2; - - use Moose; -} - -{ - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class2', - metaclass_roles => ['Role::Foo'], - attribute_metaclass_roles => ['Role::Foo'], - method_metaclass_roles => ['Role::Foo'], - instance_metaclass_roles => ['Role::Foo'], - constructor_class_roles => ['Role::Foo'], - destructor_class_roles => ['Role::Foo'], - ); - - ok( My::Class2->meta()->meta()->does_role('Role::Foo'), - 'apply Role::Foo to My::Class2->meta()' ); - is( My::Class2->meta()->foo(), 10, - '... and call foo() on that meta object' ); - ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), - q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} ); - My::Class2->meta()->add_attribute( 'size', is => 'ro' ); - - is( My::Class2->meta()->get_attribute('size')->foo(), 10, - '... call foo() on an attribute metaclass object' ); - - ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'), - q{apply Role::Foo to My::Class2->meta()'s method metaclass} ); - - My::Class2->meta()->add_method( 'bar' => sub { 'bar' } ); - is( My::Class2->meta()->get_method('bar')->foo(), 10, - '... call foo() on a method metaclass object' ); - - ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), - q{apply Role::Foo to My::Class2->meta()'s instance metaclass} ); - is( My::Class2->meta()->get_meta_instance()->foo(), 10, - '... call foo() on an instance metaclass object' ); - - ok( My::Class2->meta()->constructor_class()->meta()->does_role('Role::Foo'), - q{apply Role::Foo to My::Class2->meta()'s constructor class} ); - ok( My::Class2->meta()->constructor_class()->can('foo'), - '... constructor class has a foo method' ); - - ok( My::Class2->meta()->destructor_class()->meta()->does_role('Role::Foo'), - q{apply Role::Foo to My::Class2->meta()'s destructor class} ); - ok( My::Class2->meta()->destructor_class()->can('foo'), - '... destructor class has a foo method' ); -} - - -{ - package My::Meta; - - use 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_metaclass_roles( - for_class => 'My::Class3', - metaclass_roles => ['Role::Foo'], - ); - - ok( My::Class3->meta()->meta()->does_role('Role::Foo'), - 'apply Role::Foo to My::Class3->meta()' ); - is( My::Class3->meta()->foo(), 10, - '... and call foo() on that meta object' ); - ok( ( grep { $_ eq 'My::Meta::Class' } My::Class3->meta()->meta()->superclasses() ), - 'apply_metaclass_roles() does not interfere with metaclass set via Moose->init_meta()' ); -} - -{ - package Role::Bar; - use Moose::Role; - has 'bar' => ( is => 'ro', default => 200 ); -} - -{ - package My::Class4; - use Moose; -} - -{ - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class4', - metaclass_roles => ['Role::Foo'], - ); - - ok( My::Class4->meta()->meta()->does_role('Role::Foo'), - 'apply Role::Foo to My::Class4->meta()' ); - - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class4', - metaclass_roles => ['Role::Bar'], - ); - - ok( My::Class4->meta()->meta()->does_role('Role::Bar'), - 'apply Role::Bar to My::Class4->meta()' ); - ok( My::Class4->meta()->meta()->does_role('Role::Foo'), - '... and My::Class4->meta() still does Role::Foo' ); -} - -{ - package My::Class5; - use 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_metaclass_roles( - for_class => 'My::Class5', - metaclass_roles => ['Role::Bar'], - ); - - ok( My::Class5->meta()->meta()->does_role('Role::Bar'), - q{apply Role::Bar My::Class5->meta()} ); - ok( My::Class5->meta()->meta()->does_role('Role::Foo'), - q{... and My::Class5->meta() still does Role::Foo} ); -} - -{ - package My::Class6; - use Moose; - - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class6', - metaclass_roles => ['Role::Bar'], - ); - - extends 'My::Class'; -} - -{ - ok( My::Class6->meta()->meta()->does_role('Role::Bar'), - q{apply Role::Bar My::Class6->meta() before extends} ); - ok( My::Class6->meta()->meta()->does_role('Role::Foo'), - q{... and My::Class6->meta() does Role::Foo because My::Class6 extends My::Class} ); -} - -# This is the hack that used to be needed to work around the -# _fix_metaclass_incompatibility problem. You called extends() (which -# in turn calls _fix_metaclass_imcompatibility) _before_ you apply -# more extensions in the subclass. We wabt to make sure this continues -# to work in the future. -{ - package My::Class7; - use Moose; - - # In real usage this would go in a BEGIN block so it happened - # before apply_metaclass_roles was called by an extension. - extends 'My::Class'; - - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class7', - metaclass_roles => ['Role::Bar'], - ); -} - -{ - ok( My::Class7->meta()->meta()->does_role('Role::Bar'), - q{apply Role::Bar My::Class7->meta() before extends} ); - ok( My::Class7->meta()->meta()->does_role('Role::Foo'), - q{... and My::Class7->meta() does Role::Foo because My::Class7 extends My::Class} ); -} - -{ - package My::Class8; - use Moose; - - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class8', - metaclass_roles => ['Role::Bar'], - attribute_metaclass_roles => ['Role::Bar'], - ); - - extends 'My::Class'; -} - -{ - ok( My::Class8->meta()->meta()->does_role('Role::Bar'), - q{apply Role::Bar My::Class8->meta() before extends} ); - ok( My::Class8->meta()->meta()->does_role('Role::Foo'), - q{... and My::Class8->meta() does Role::Foo because My::Class8 extends My::Class} ); - ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Bar'), - q{apply Role::Bar to My::Class8->meta()->attribute_metaclass before extends} ); - ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Foo'), - q{... and My::Class8->meta()->attribute_metaclass does Role::Foo because My::Class8 extends My::Class} ); -} - - -{ - package My::Class9; - use Moose; - - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class9', - attribute_metaclass_roles => ['Role::Bar'], - ); - - extends 'My::Class'; -} - -{ - ok( My::Class9->meta()->meta()->does_role('Role::Foo'), - q{... and My::Class9->meta() does Role::Foo because My::Class9 extends My::Class} ); - ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Bar'), - q{apply Role::Bar to My::Class9->meta()->attribute_metaclass before extends} ); - ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Foo'), - q{... and My::Class9->meta()->attribute_metaclass does Role::Foo because My::Class9 extends My::Class} ); -} - -# This tests applying meta roles to a metaclass's metaclass. This is -# completely insane, but is exactly what happens with -# Fey::Meta::Class::Table. It's a subclass of 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_metaclass_roles( - for_class => 'My::Meta::Class2', - metaclass_roles => ['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_metaclass_roles( - for_class => 'My::Class10', - metaclass_roles => ['Role::Bar'], - ); -} - -{ - ok( My::Class10->meta()->meta()->meta()->does_role('Role::Foo'), - q{My::Class10->meta()->meta() does Role::Foo } ); - ok( My::Class10->meta()->meta()->does_role('Role::Bar'), - q{My::Class10->meta()->meta() does Role::Bar } ); - ok( My::Class10->meta()->isa('My::Meta::Class2'), - q{... and My::Class10->meta still isa(My::Meta::Class2)} ); - ok( My::Class10->isa('My::Object'), - q{... and My::Class10 still isa(My::Object)} ); -} - -{ - package My::Constructor; - - use base 'Moose::Meta::Method::Constructor'; -} - -{ - package My::Class11; - - use Moose; - - __PACKAGE__->meta->constructor_class('My::Constructor'); - - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => 'My::Class11', - metaclass_roles => ['Role::Foo'], - ); -} - -{ - ok( My::Class11->meta()->meta()->does_role('Role::Foo'), - q{My::Class11->meta()->meta() does Role::Foo } ); - is( My::Class11->meta()->constructor_class, 'My::Constructor', - q{... and explicitly set constructor_class value is unchanged)} ); -} - -{ - package ExportsMoose; - - Moose::Exporter->setup_import_methods( - also => 'Moose', - ); - - sub init_meta { - shift; - my %p = @_; - Moose->init_meta(%p); - return Moose::Util::MetaRole::apply_metaclass_roles( - for_class => $p{for_class}, - # Causes us to recurse through init_meta, as we have to - # load MyMetaclassRole from disk. - metaclass_roles => [qw/MyMetaclassRole/], - ); - } -} - -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_metaclass_roles( - for_class => $p{for_class}, - method_metaclass_roles => [ 'Foo::Meta::Role', ], - ); - } -} -{ - package Role::Baz; - - Foo::Role->import; - - sub bla {} -} -{ - package My::Class12; - - use 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_metaclass_roles( - for_class => __PACKAGE__, - constructor_class_roles => ['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/type_constraints/util_find_type_constraint.t b/t/type_constraints/util_find_type_constraint.t index 0f2773d..fcf182d 100644 --- a/t/type_constraints/util_find_type_constraint.t +++ b/t/type_constraints/util_find_type_constraint.t @@ -26,7 +26,6 @@ foreach my $type_name (qw( CodeRef RegexpRef Object - Role )) { is(find_type_constraint($type_name)->name, $type_name, diff --git a/t/type_constraints/util_type_constraints.t b/t/type_constraints/util_type_constraints.t index 2b26d5f..04dd3aa 100644 --- a/t/type_constraints/util_type_constraints.t +++ b/t/type_constraints/util_type_constraints.t @@ -188,44 +188,4 @@ like( exception {$r->add_type_constraint(bless {}, 'SomeClass')}, qr/not a valid like( exception { subtype 'Foo' }, qr/cannot consist solely of a name/, 'Cannot call subtype with a single string argument' ); } -# Back-compat for being called without sugar. Previously, calling with -# sugar was indistinguishable from calling directly. - -{ - no warnings 'redefine'; - *Moose::Deprecated::deprecated = sub { return }; -} - -{ - my $type = type( 'Number2', sub { Scalar::Util::looks_like_number($_) } ); - - ok( $type->check(5), '... this is a Num' ); - ok( ! $type->check('Foo'), '... this is not a Num' ); -} - -{ - # anon subtype - my $subtype = subtype( 'Number2', sub { $_ > 0 } ); - - ok( $subtype->check(5), '... this is a Natural'); - ok( ! $subtype->check(-5), '... this is not a Natural'); - ok( ! $subtype->check('Foo'), '... this is not a Natural'); -} - -{ - my $subtype = subtype( 'Natural2', 'Number2', sub { $_ > 0 } ); - - ok( $subtype->check(5), '... this is a Natural'); - ok( ! $subtype->check(-5), '... this is not a Natural'); - ok( ! $subtype->check('Foo'), '... this is not a Natural'); -} - -{ - my $subtype = subtype( 'Natural3', 'Number2' ); - - ok( $subtype->check(5), '... this is a Natural'); - ok( $subtype->check(-5), '... this is a Natural'); - ok( ! $subtype->check('Foo'), '... this is not a Natural'); -} - done_testing;