From: gfx Date: Mon, 21 Sep 2009 06:19:11 +0000 (+0900) Subject: Make anonymous classes work correctly X-Git-Tag: 0.32~31 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=ad022aac12ce95ee336af9dde0758ae98037f3ab Make anonymous classes work correctly --- diff --git a/Changes b/Changes index c58e5fa..8285f99 100644 --- a/Changes +++ b/Changes @@ -2,6 +2,12 @@ Revision history for Mouse 0.30 + * Work around anonymous classes as mortal classes + + * Implement with $role => -exlucdes => [...] (gfx) + + * Implement get_method() in M::Meta::Class and M::Meta::Role (gfx) + * Make get_method_list() compatible with Moose's (gfx) * Make unimport() not to remove non-Mouse functions (blessed and confess) (gfx) @@ -10,8 +16,6 @@ Revision history for Mouse * Support is => 'bare', and you must pass and 'is' option to has() (gfx) - * Make generator methods private (gfx) - 0.29 Thu Sep 17 11:49:49 2009 * role class has ->meta in method_list, because it does in Moose since 0.9 diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index 6fcb576..a9c76f4 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -307,19 +307,14 @@ sub create { || $class->throw_error("You must pass a HASH ref of methods") if exists $options{methods}; - do { + { ( defined $package_name && $package_name ) || $class->throw_error("You must pass a package name"); - my $code = "package $package_name;"; - $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';" - if exists $options{version}; - $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';" - if exists $options{authority}; - - eval $code; - $class->throw_error("creation of $package_name failed : $@") if $@; - }; + no strict 'refs'; + ${ $package_name . '::VERSION' } = $options{version} if exists $options{version}; + ${ $package_name . '::AUTHORITY' } = $options{authority} if exists $options{authority}; + } my %initialize_options = %options; delete @initialize_options{qw( @@ -360,11 +355,58 @@ sub create { { my $ANON_CLASS_SERIAL = 0; my $ANON_CLASS_PREFIX = 'Mouse::Meta::Class::__ANON__::SERIAL::'; + + my %IMMORTAL_ANON_CLASSES; sub create_anon_class { my ( $class, %options ) = @_; + + my $cache = $options{cache}; + my $cache_key; + + if($cache){ # anonymous but not mortal + # something like Super::Class|Super::Class::2=Role|Role::1 + $cache_key = join '=' => ( + join('|', @{$options{superclasses} || []}), + join('|', sort @{$options{roles} || []}), + ); + return $IMMORTAL_ANON_CLASSES{$cache_key} if exists $IMMORTAL_ANON_CLASSES{$cache_key}; + } my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL; - return $class->create( $package_name, %options ); + my $meta = $class->create( $package_name, anon_class_id => $ANON_CLASS_SERIAL, %options ); + + if($cache){ + $IMMORTAL_ANON_CLASSES{$cache_key} = $meta; + } + else{ + Mouse::Meta::Module::weaken_metaclass($package_name); + } + return $meta; } + + sub is_anon_class{ + return exists $_[0]->{anon_class_id}; + } + + + sub DESTROY{ + my($self) = @_; + + my $serial_id = $self->{anon_class_id}; + + return if !$serial_id; + + my $stash = $self->namespace; + + @{$self->{sperclasses}} = (); + %{$stash} = (); + Mouse::Meta::Module::remove_metaclass_by_name($self->name); + + no strict 'refs'; + delete ${$ANON_CLASS_PREFIX}{ $serial_id . '::' }; + + return; + } + } 1; diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm index 12b0453..6e4179b 100755 --- a/lib/Mouse/Meta/Module.pm +++ b/lib/Mouse/Meta/Module.pm @@ -3,7 +3,7 @@ use strict; use warnings; use Mouse::Util qw/get_code_info not_supported load_class/; -use Scalar::Util qw/blessed/; +use Scalar::Util qw/blessed weaken/; { diff --git a/t/028-subclass-attr.t b/t/028-subclass-attr.t index ca221d0..9a4eaba 100644 --- a/t/028-subclass-attr.t +++ b/t/028-subclass-attr.t @@ -26,10 +26,10 @@ my $obj = Child->new(class => 1, child => 1); ok($obj->child, "local attribute set in constructor"); ok($obj->class, "inherited attribute set in constructor"); -is_deeply([Child->meta->get_all_attributes], [ +is_deeply([sort(Child->meta->get_all_attributes)], [sort( Child->meta->get_attribute('child'), Class->meta->get_attribute('class'), -], "correct get_all_attributes"); +)], "correct get_all_attributes"); do { package Foo; diff --git a/t/030_roles/003_apply_role.t b/t/030_roles/003_apply_role.t index b4d2b38..499f4f7 100755 --- a/t/030_roles/003_apply_role.t +++ b/t/030_roles/003_apply_role.t @@ -3,7 +3,15 @@ use strict; use warnings; -use Test::More tests => 86; +use Test::More; +BEGIN{ + if(eval{ require Class::Method::Modifiers::Fast } || eval{ require Class::Method::Modifier }){ + plan tests => 86; + } + else{ + plan skip_all => 'This test requires Class::Method::Modifiers(::Fast)?'; + } +} use Test::Exception; { diff --git a/t/030_roles/009_more_role_edge_cases.t b/t/030_roles/009_more_role_edge_cases.t index d7c95a4..cf64696 100644 --- a/t/030_roles/009_more_role_edge_cases.t +++ b/t/030_roles/009_more_role_edge_cases.t @@ -2,8 +2,16 @@ use strict; use warnings; +use Test::More; +BEGIN{ + if(eval{ require Class::Method::Modifiers::Fast } || eval{ require Class::Method::Modifier }){ + plan tests => 74; + } + else{ + plan skip_all => 'This test requires Class::Method::Modifiers(::Fast)?'; + } +} -use Test::More tests => 74; use Test::Exception; diff --git a/t/030_roles/019_build.t b/t/030_roles/019_build.t index 475e4fb..1a7a402 100755 --- a/t/030_roles/019_build.t +++ b/t/030_roles/019_build.t @@ -5,6 +5,11 @@ use Test::More; BEGIN { eval "use Test::Output;"; plan skip_all => "Test::Output is required for this test" if $@; + + unless(eval { require Class::Method::Modifiers::Fast } or eval{ require Class::Method::Modifiers }){ + plan skip_all => "Class::Method::Modifiers(::Fast)? is required for this test" if $@; + } + plan tests => 8; } diff --git a/t/030_roles/failing/001_meta_role.t b/t/030_roles/failing/001_meta_role.t deleted file mode 100755 index 940d719..0000000 --- a/t/030_roles/failing/001_meta_role.t +++ /dev/null @@ -1,106 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::More tests => 25; -use Test::Exception; - -use Mouse::Meta::Role; - -{ - package FooRole; - - our $VERSION = '0.01'; - - sub foo { 'FooRole::foo' } -} - -my $foo_role = Mouse::Meta::Role->initialize('FooRole'); -isa_ok($foo_role, 'Mouse::Meta::Role'); -#isa_ok($foo_role, 'Class::MOP::Module'); ## Mouse: doesn't use Class::MOP - -is($foo_role->name, 'FooRole', '... got the right name of FooRole'); -#is($foo_role->version, '0.01', '... got the right version of FooRole'); ## Mouse: ->version is cfrom Class::MOP - -# methods ... - -ok($foo_role->has_method('foo'), '... FooRole has the foo method'); -is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method'); - -isa_ok($foo_role->get_method('foo'), 'Mouse::Meta::Role::Method'); - -is_deeply( - [ $foo_role->get_method_list() ], - [ 'foo' ], - '... got the right method list'); - -# attributes ... - -is_deeply( - [ $foo_role->get_attribute_list() ], - [], - '... got the right attribute list'); - -ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); - -lives_ok { - $foo_role->add_attribute('bar' => (is => 'rw', isa => 'Foo')); -} '... added the bar attribute okay'; - -is_deeply( - [ $foo_role->get_attribute_list() ], - [ 'bar' ], - '... got the right attribute list'); - -ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute'); - -is_deeply( - $foo_role->get_attribute('bar'), - { is => 'rw', isa => 'Foo' }, - '... got the correct description of the bar attribute'); - -lives_ok { - $foo_role->add_attribute('baz' => (is => 'ro')); -} '... added the baz attribute okay'; - -is_deeply( - [ sort $foo_role->get_attribute_list() ], - [ 'bar', 'baz' ], - '... got the right attribute list'); - -ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute'); - -is_deeply( - $foo_role->get_attribute('baz'), - { is => 'ro' }, - '... got the correct description of the baz attribute'); - -lives_ok { - $foo_role->remove_attribute('bar'); -} '... removed the bar attribute okay'; - -is_deeply( - [ $foo_role->get_attribute_list() ], - [ 'baz' ], - '... got the right attribute list'); - -ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); -ok($foo_role->has_attribute('baz'), '... FooRole does still have the baz attribute'); - -# method modifiers - -ok(!$foo_role->has_before_method_modifiers('boo'), '... no boo:before modifier'); - -my $method = sub { "FooRole::boo:before" }; -lives_ok { - $foo_role->add_before_method_modifier('boo' => $method); -} '... added a method modifier okay'; - -ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier'); -is(($foo_role->get_before_method_modifiers('boo'))[0], $method, '... got the right method back'); - -is_deeply( - [ $foo_role->get_method_modifier_list('before') ], - [ 'boo' ], - '... got the right list of before method modifiers'); diff --git a/t/030_roles/failing/009_more_role_edge_cases.t b/t/030_roles/failing/009_more_role_edge_cases.t deleted file mode 100644 index 79abf14..0000000 --- a/t/030_roles/failing/009_more_role_edge_cases.t +++ /dev/null @@ -1,256 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::More tests => 74; -use Test::Exception; - - - -{ - # NOTE: - # this tests that repeated role - # composition will not cause - # a conflict between two methods - # which are actually the same anyway - - { - package RootA; - use Mouse::Role; - - sub foo { "RootA::foo" } - - package SubAA; - use Mouse::Role; - - with "RootA"; - - sub bar { "SubAA::bar" } - - package SubAB; - use Mouse; - - ::lives_ok { - with "SubAA", "RootA"; - } '... role was composed as expected'; - } - - ok( SubAB->does("SubAA"), "does SubAA"); - ok( SubAB->does("RootA"), "does RootA"); - - isa_ok( my $i = SubAB->new, "SubAB" ); - - can_ok( $i, "bar" ); - is( $i->bar, "SubAA::bar", "... got thr right bar rv" ); - - can_ok( $i, "foo" ); - my $foo_rv; - lives_ok { - $foo_rv = $i->foo; - } '... called foo successfully'; - is($foo_rv, "RootA::foo", "... got the right foo rv"); -} - -{ - # NOTE: - # this edge cases shows the application of - # an after modifier over a method which - # was added during role composotion. - # The way this will work is as follows: - # role SubBA will consume RootB and - # get a local copy of RootB::foo, it - # will also store a deferred after modifier - # to be applied to whatever class SubBA is - # composed into. - # When class SubBB comsumed role SubBA, the - # RootB::foo method is added to SubBB, then - # the deferred after modifier from SubBA is - # applied to it. - # It is important to note that the application - # of the after modifier does not happen until - # role SubBA is composed into SubAA. - - { - package RootB; - use Mouse::Role; - - sub foo { "RootB::foo" } - - package SubBA; - use Mouse::Role; - - with "RootB"; - - has counter => ( - isa => "Num", - is => "rw", - default => 0, - ); - - after foo => sub { - $_[0]->counter( $_[0]->counter + 1 ); - }; - - package SubBB; - use Mouse; - - ::lives_ok { - with "SubBA"; - } '... composed the role successfully'; - } - - ok( SubBB->does("SubBA"), "BB does SubBA" ); - ok( SubBB->does("RootB"), "BB does RootB" ); - - isa_ok( my $i = SubBB->new, "SubBB" ); - - can_ok( $i, "foo" ); - - my $foo_rv; - lives_ok { - $foo_rv = $i->foo - } '... called foo successfully'; - is( $foo_rv, "RootB::foo", "foo rv" ); - is( $i->counter, 1, "after hook called" ); - - lives_ok { $i->foo } '... called foo successfully (again)'; - is( $i->counter, 2, "after hook called (again)" ); - - ok(SubBA->meta->has_method('foo'), '... this has the foo method'); - #my $subba_foo_rv; - #lives_ok { - # $subba_foo_rv = SubBA::foo(); - #} '... called the sub as a function correctly'; - #is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version'); -} - -{ - # NOTE: - # this checks that an override method - # does not try to trample over a locally - # composed in method. In this case the - # RootC::foo, which is composed into - # SubCA cannot be trampled with an - # override of 'foo' - { - package RootC; - use Mouse::Role; - - sub foo { "RootC::foo" } - - package SubCA; - use Mouse::Role; - - with "RootC"; - - ::dies_ok { - override foo => sub { "overridden" }; - } '... cannot compose an override over a local method'; - } -} - -# NOTE: -# need to talk to Yuval about the motivation behind -# this test, I am not sure we are testing anything -# useful here (although more tests cant hurt) - -{ - use List::Util qw/shuffle/; - - { - package Abstract; - use Mouse::Role; - - requires "method"; - requires "other"; - - sub another { "abstract" } - - package ConcreteA; - use Mouse::Role; - with "Abstract"; - - sub other { "concrete a" } - - package ConcreteB; - use Mouse::Role; - with "Abstract"; - - sub method { "concrete b" } - - package ConcreteC; - use Mouse::Role; - with "ConcreteA"; - - # NOTE: - # this was originally override, but - # that wont work (see above set of tests) - # so I switched it to around. - # However, this may not be testing the - # same thing that was originally intended - around other => sub { - return ( (shift)->() . " + c" ); - }; - - package SimpleClassWithSome; - use Mouse; - - eval { with ::shuffle qw/ConcreteA ConcreteB/ }; - ::ok( !$@, "simple composition without abstract" ) || ::diag $@; - - package SimpleClassWithAll; - use Mouse; - - eval { with ::shuffle qw/ConcreteA ConcreteB Abstract/ }; - ::ok( !$@, "simple composition with abstract" ) || ::diag $@; - } - - foreach my $class (qw/SimpleClassWithSome SimpleClassWithAll/) { - foreach my $role (qw/Abstract ConcreteA ConcreteB/) { - ok( $class->does($role), "$class does $role"); - } - - foreach my $method (qw/method other another/) { - can_ok( $class, $method ); - } - - is( eval { $class->another }, "abstract", "provided by abstract" ); - is( eval { $class->other }, "concrete a", "provided by concrete a" ); - is( eval { $class->method }, "concrete b", "provided by concrete b" ); - } - - { - package ClassWithSome; - use Mouse; - - eval { with ::shuffle qw/ConcreteC ConcreteB/ }; - ::ok( !$@, "composition without abstract" ) || ::diag $@; - - package ClassWithAll; - use Mouse; - - eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ }; - ::ok( !$@, "composition with abstract" ) || ::diag $@; - - package ClassWithEverything; - use Mouse; - - eval { with ::shuffle qw/ConcreteC Abstract ConcreteA ConcreteB/ }; # this should clash - ::ok( !$@, "can compose ConcreteA and ConcreteC together" ); - } - - foreach my $class (qw/ClassWithSome ClassWithAll ClassWithEverything/) { - foreach my $role (qw/Abstract ConcreteA ConcreteB ConcreteC/) { - ok( $class->does($role), "$class does $role"); - } - - foreach my $method (qw/method other another/) { - can_ok( $class, $method ); - } - - is( eval { $class->another }, "abstract", "provided by abstract" ); - is( eval { $class->other }, "concrete a + c", "provided by concrete c + a" ); - is( eval { $class->method }, "concrete b", "provided by concrete b" ); - } -} diff --git a/t/800_shikabased/008-create_class.t b/t/800_shikabased/008-create_class.t index 387861e..687671e 100644 --- a/t/800_shikabased/008-create_class.t +++ b/t/800_shikabased/008-create_class.t @@ -1,7 +1,7 @@ use strict; use warnings; use Mouse (); -use Test::More tests => 14; +use Test::More tests => 20; use Test::Exception; # error handling @@ -58,6 +58,7 @@ isa_ok Baz->new(), "FooBar"; is Baz->new()->foo, "yay"; is Baz->new()->dooo, "iiiit"; +my($anon_pkg1, $anon_pkg2); { my $meta = Mouse::Meta::Class->create_anon_class( superclasses => [ "Mouse::Object" ], @@ -65,10 +66,25 @@ is Baz->new()->dooo, "iiiit"; dooo => sub { "iiiit" }, } ); - isa_ok($meta, "Mouse::Meta::Class"); - like($meta->name, qr/Class::__ANON__::/); + $anon_pkg1 = $meta->name; + + isa_ok($meta, "Mouse::Meta::Class", 'create_anon_class'); + ok($meta->is_anon_class, 'is_anon_class'); is $meta->name->new->dooo(), "iiiit"; - my $anon2 = Mouse::Meta::Class->create_anon_class(); - like($anon2->name, qr/Class::__ANON__::/); + my $anon2 = Mouse::Meta::Class->create_anon_class(cache => 1); + $anon_pkg2 = $anon2->name; + + ok($anon2->is_anon_class); + + isnt $meta, $anon2; + isnt $meta->name, $anon2->name; } + +# all the stuff are removed? +ok !$anon_pkg1->isa('Mouse::Object'); +ok !$anon_pkg1->can('dooo'); +ok !$anon_pkg1->can('meta'); + +ok $anon_pkg2->can('meta'), 'cache => 1 makes it immortal'; +