adding metaclass alias stuff

diff --git a/Changes b/Changes
index 6304094..2eb8e43 100644 (file)
--- a/Changes
+++ b/Changes
@@ -2,11 +2,11 @@ Revision history for Perl extension Moose
 
 0.19
     * Moose::Util::TypeConstraints
-      - type now supports messages as well
+      - 'type' now supports messages as well
         thanks to phaylon for finding this
         - added tests for this
-      - added list_all_type_constraints and 
-        list_all_builtin_type_constraints
+      - added &list_all_type_constraints and 
+        &list_all_builtin_type_constraints
         functions to facilitate introspection.
     
     * Moose::Meta::Attribute
@@ -16,12 +16,19 @@ Revision history for Perl extension Moose
         things like &new) thanks to ashleyb 
         for finding this
         - added tests and docs for this
-      - added the "documentation" attributes
+      - added the 'documentation' attributes
         so that you can actually document your 
         attributes and inspect them through the 
         meta-object.
         - added tests and docs for this
 
+    * Moose::Meta::Class
+      - when loading custom attribute metaclasses
+        it will first look in for the class in the 
+        Moose::Meta::Attribute::Custom::$name, and 
+        then default to just loading $name.
+        - added tests and docs for this
+
     * Moose::Meta::TypeConstraint
       - type constraints now stringify to their names.
         - added test for this

diff --git a/lib/Moose.pm b/lib/Moose.pm
index 4de5436..553c7e3 100644 (file)
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -424,6 +424,22 @@ If an attribute is marked as lazy it B<must> have a default supplied.
 This tells the accessor whether to automatically dereference the value returned. 
 This is only legal if your C<isa> option is either an C<ArrayRef> or C<HashRef>.
 
+=item I<metaclass =E<gt> $metaclass_name>
+
+This tells the class to use a custom attribute metaclass for this particular 
+attribute. Custom attribute metaclasses are useful for extending the capabilities 
+of the I<has> keyword, they are the simplest way to extend the MOP, but they are 
+still a fairly advanced topic and too much to cover here. I will try and write a 
+recipe on it soon.
+
+The default behavior here is to just load C<$metaclass_name>, however, we also 
+have a way to alias to a shorter name. This will first look to see if 
+B<Moose::Meta::Attribute::Custom::$metaclass_name> exists, if it does it will 
+then check to see if that has the method C<register_implemenetation> which 
+should return the actual name of the custom attribute metaclass. If there is 
+no C<register_implemenetation> method, it will just default to using 
+B<Moose::Meta::Attribute::Custom::$metaclass_name> as the metaclass name.
+
 =item I<trigger =E<gt> $code>
 
 The trigger option is a CODE reference which will be called after the value of 

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 44cf326..3354d07 100644 (file)
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -9,7 +9,7 @@ use Class::MOP;
 use Carp         'confess';
 use Scalar::Util 'weaken', 'blessed', 'reftype';
 
-our $VERSION   = '0.11';
+our $VERSION   = '0.12';
 our $AUTHORITY = 'cpan:STEVAN';
 
 use Moose::Meta::Method::Overriden;
@@ -275,8 +275,18 @@ sub _process_attribute {
     }
     else {
         if ($options{metaclass}) {
-            Class::MOP::load_class($options{metaclass});
-            $self->add_attribute($options{metaclass}->new($name, %options));
+            my $metaclass_name = $options{metaclass};
+            eval {
+                my $possible_full_name = 'Moose::Meta::Attribute::Custom::' . $metaclass_name;
+                Class::MOP::load_class($possible_full_name);                
+                $metaclass_name = $possible_full_name->can('register_implementation') 
+                    ? $possible_full_name->register_implementation
+                    : $possible_full_name;
+            };
+            if ($@) {
+                Class::MOP::load_class($metaclass_name);
+            }
+            $self->add_attribute($metaclass_name->new($name, %options));
         }
         else {
             $self->add_attribute($name, %options);

diff --git a/t/036_attribute_custom_metaclass.t b/t/036_attribute_custom_metaclass.t
index 46cd8f0..a7b8bdb 100644 (file)
--- a/t/036_attribute_custom_metaclass.t
+++ b/t/036_attribute_custom_metaclass.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 11;
+use Test::More tests => 17;
 use Test::Exception;
 
 BEGIN {
@@ -28,25 +28,25 @@ BEGIN {
     
     has 'foo' => (metaclass => 'Foo::Meta::Attribute');
 }
+{
+    my $foo = Foo->new;
+    isa_ok($foo, 'Foo');
 
-my $foo = Foo->new;
-isa_ok($foo, 'Foo');
-
-my $foo_attr = Foo->meta->get_attribute('foo');
-isa_ok($foo_attr, 'Foo::Meta::Attribute');
-isa_ok($foo_attr, 'Moose::Meta::Attribute');
-
-is($foo_attr->name, 'foo', '... got the right name for our meta-attribute');
-ok($foo_attr->has_accessor, '... our meta-attrubute created the accessor for us');
+    my $foo_attr = Foo->meta->get_attribute('foo');
+    isa_ok($foo_attr, 'Foo::Meta::Attribute');
+    isa_ok($foo_attr, 'Moose::Meta::Attribute');
 
-ok($foo_attr->has_type_constraint, '... our meta-attrubute created the type_constraint for us');
+    is($foo_attr->name, 'foo', '... got the right name for our meta-attribute');
+    ok($foo_attr->has_accessor, '... our meta-attrubute created the accessor for us');
 
-my $foo_attr_type_constraint = $foo_attr->type_constraint;
-isa_ok($foo_attr_type_constraint, 'Moose::Meta::TypeConstraint');
+    ok($foo_attr->has_type_constraint, '... our meta-attrubute created the type_constraint for us');
 
-is($foo_attr_type_constraint->name, 'Foo', '... got the right type constraint name');
-is($foo_attr_type_constraint->parent->name, 'Object', '... got the right type constraint parent name');
+    my $foo_attr_type_constraint = $foo_attr->type_constraint;
+    isa_ok($foo_attr_type_constraint, 'Moose::Meta::TypeConstraint');
 
+    is($foo_attr_type_constraint->name, 'Foo', '... got the right type constraint name');
+    is($foo_attr_type_constraint->parent->name, 'Object', '... got the right type constraint parent name');
+}
 {
     package Bar::Meta::Attribute;
     use Moose;
@@ -61,3 +61,35 @@ is($foo_attr_type_constraint->parent->name, 'Object', '... got the right type co
     } '... the attribute metaclass need not be a Moose::Meta::Attribute as long as it behaves';
 }
 
+{
+    package Moose::Meta::Attribute::Custom::Foo;
+    sub register_implementation { 'Foo::Meta::Attribute' }
+    
+    package Moose::Meta::Attribute::Custom::Bar;
+    use Moose;
+    
+    extends 'Moose::Meta::Attribute';
+    
+    package Another::Foo;
+    use Moose;
+    
+    ::lives_ok {
+        has 'foo' => (metaclass => 'Foo');    
+    } '... the attribute metaclass alias worked correctly';
+    
+    ::lives_ok {
+        has 'bar' => (metaclass => 'Bar');    
+    } '... the attribute metaclass alias worked correctly';    
+}
+
+{
+    my $foo_attr = Another::Foo->meta->get_attribute('foo');
+    isa_ok($foo_attr, 'Foo::Meta::Attribute');
+    isa_ok($foo_attr, 'Moose::Meta::Attribute');
+    
+    my $bar_attr = Another::Foo->meta->get_attribute('bar');
+    isa_ok($bar_attr, 'Moose::Meta::Attribute::Custom::Bar');
+    isa_ok($bar_attr, 'Moose::Meta::Attribute');    
+}
+
+