From: Guillermo Roditi Date: Tue, 29 May 2007 20:50:45 +0000 (+0000) Subject: tiny change in metaclass.pm to automatically load custom metaclass X-Git-Tag: 0_38~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=95514cb4a1bc0120b516ee8a146c770e919432a3;p=gitmo%2FClass-MOP.git tiny change in metaclass.pm to automatically load custom metaclass --- diff --git a/Changes b/Changes index 28a5801..8b2686c 100644 --- a/Changes +++ b/Changes @@ -25,7 +25,11 @@ Revision history for Perl extension Class-MOP. obscure enough feature that there are not too many work arounds out in the wild. - added tests for this by groditi - - updated docs to explain this + - updated docs to explain this + + * metaclass + - load custom metaclass automatically. + - modified tests to test this behavior 0.37 Sat. March 10, 2007 ~~ Many, many documentation updates ~~ diff --git a/lib/metaclass.pm b/lib/metaclass.pm index 80e10aa..2e215c4 100644 --- a/lib/metaclass.pm +++ b/lib/metaclass.pm @@ -20,19 +20,20 @@ sub import { } else { $metaclass = shift; + Class::MOP::load_class($metaclass); ($metaclass->isa('Class::MOP::Class')) || confess "The metaclass ($metaclass) must be derived from Class::MOP::Class"; } my %options = @_; my $package = caller(); - + # create a meta object so we can install &meta my $meta = $metaclass->initialize($package => %options); $meta->add_method('meta' => sub { - # we must re-initialize so that it - # works as expected in subclasses, - # since metaclass instances are - # singletons, this is not really a + # we must re-initialize so that it + # works as expected in subclasses, + # since metaclass instances are + # singletons, this is not really a # big deal anyway. $metaclass->initialize((blessed($_[0]) || $_[0]) => %options) }); @@ -53,17 +54,17 @@ metaclass - a pragma for installing and using Class::MOP metaclasses package MyClass; # use Class::MOP::Class - use metaclass; + use metaclass; # ... or use a custom metaclass use metaclass 'MyMetaClass'; - - # ... or use a custom metaclass + + # ... or use a custom metaclass # and custom attribute and method # metaclasses use metaclass 'MyMetaClass' => ( 'attribute_metaclass' => 'MyAttributeMetaClass', - 'method_metaclass' => 'MyMethodMetaClass', + 'method_metaclass' => 'MyMethodMetaClass', ); # ... or just specify custom attribute @@ -71,14 +72,14 @@ metaclass - a pragma for installing and using Class::MOP metaclasses # is the assumed metaclass use metaclass ( 'attribute_metaclass' => 'MyAttributeMetaClass', - 'method_metaclass' => 'MyMethodMetaClass', + 'method_metaclass' => 'MyMethodMetaClass', ); =head1 DESCRIPTION -This is a pragma to make it easier to use a specific metaclass -and a set of custom attribute and method metaclasses. It also -installs a C method to your class as well. +This is a pragma to make it easier to use a specific metaclass +and a set of custom attribute and method metaclasses. It also +installs a C method to your class as well. =head1 AUTHORS @@ -91,6 +92,6 @@ Copyright 2006, 2007 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut diff --git a/t/006_new_and_clone_metaclasses.t b/t/006_new_and_clone_metaclasses.t index b30e03b..b64119d 100644 --- a/t/006_new_and_clone_metaclasses.t +++ b/t/006_new_and_clone_metaclasses.t @@ -3,6 +3,9 @@ use strict; use warnings; +use FindBin; +use File::Spec::Functions; + use Test::More tests => 36; use Test::Exception; @@ -10,6 +13,8 @@ BEGIN { use_ok('Class::MOP'); } +use lib catdir($FindBin::Bin, 'lib'); + # make sure the Class::MOP::Class->meta does the right thing my $meta = Class::MOP::Class->meta(); @@ -21,7 +26,7 @@ is($new_meta, $meta, '... it still creates the singleton'); my $cloned_meta = $meta->clone_object($meta); isa_ok($cloned_meta, 'Class::MOP::Class'); -is($cloned_meta, $meta, '... it creates the singleton even if you try to clone it'); +is($cloned_meta, $meta, '... it creates the singleton even if you try to clone it'); # make sure other metaclasses do the right thing @@ -35,13 +40,8 @@ isa_ok($foo_meta, 'Class::MOP::Class'); is($meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton'); is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton'); - -# make sure subclassed of Class::MOP::Class do the right thing -{ - package MyMetaClass; - use base 'Class::MOP::Class'; -} +# make sure subclassed of Class::MOP::Class do the right thing my $my_meta = MyMetaClass->meta; isa_ok($my_meta, 'Class::MOP::Class'); @@ -67,7 +67,7 @@ is($bar_meta->version, undef, '... Bar does not exists, so it has no version'); $bar_meta->superclasses('Foo'); -# check with MyMetaClass +# check with MyMetaClass { package Baz; @@ -106,14 +106,14 @@ isnt($cloned_foo, $foo, '... $cloned_foo is a new object different from $foo'); dies_ok { $foo_meta->clone_object($meta); -} '... this dies as expected'; +} '... this dies as expected'; # test stuff { package FooBar; use metaclass; - + FooBar->meta->add_attribute('test'); } @@ -124,7 +124,7 @@ my $attr_clone = $attr->clone(); isa_ok($attr_clone, 'Class::MOP::Attribute'); isnt($attr, $attr_clone, '... we successfully cloned our attributes'); -is($attr->associated_class, - $attr_clone->associated_class, +is($attr->associated_class, + $attr_clone->associated_class, '... we successfully did not clone our associated metaclass'); diff --git a/t/lib/MyMetaClass.pm b/t/lib/MyMetaClass.pm new file mode 100644 index 0000000..7638ace --- /dev/null +++ b/t/lib/MyMetaClass.pm @@ -0,0 +1,9 @@ + +package MyMetaClass; + +use strict; +use warnings; + +use base 'Class::MOP::Class'; + +1;