metaclass and traits interpolation moved to Meta::Attribute

[gitmo/Moose.git] / lib / Moose / Meta / Attribute.pm

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index be577f8..0bd227a 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -13,6 +13,7 @@ our $VERSION   = '0.22';
 our $AUTHORITY = 'cpan:STEVAN';
 
 use Moose::Meta::Method::Accessor;
+use Moose::Util ();
 use Moose::Util::TypeConstraints ();
 
 use base 'Class::MOP::Attribute';
@@ -46,6 +47,10 @@ __PACKAGE__->meta->add_attribute('documentation' => (
     reader    => 'documentation',
     predicate => 'has_documentation',
 ));
+__PACKAGE__->meta->add_attribute('traits' => (
+    reader    => 'applied_traits',
+    predicate => 'has_applied_traits',
+));
 
 # NOTE:
 # we need to have a ->does method in here to 
@@ -61,11 +66,44 @@ sub new {
     return $class->SUPER::new($name, %options);
 }
 
+sub interpolate_class_and_new {
+    my ($class, $name, @args) = @_;
+
+    $class->interpolate_class(@args)->new($name, @args);
+}
+
+sub interpolate_class {
+    my ($class, %options) = @_;
+
+    if ( my $metaclass_name = $options{metaclass} ) {
+        $class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
+    }
+
+    if (my $traits = $options{traits}) {
+        my @traits = map {
+            Moose::Util::resolve_metatrait_alias( Attribute => $_ )
+                or
+            $_
+        } @$traits;
+
+        my $anon_class = Moose::Meta::Class->create_anon_class(
+            superclasses => [ $class ],
+            roles        => [ @traits ],
+            cache        => 1,
+        );
+
+        return $anon_class->name;
+    }
+    else {
+        return $class;
+    }
+}
+
 sub clone_and_inherit_options {
     my ($self, %options) = @_;
-    # you can change default, required, coerce, documentation and lazy
+    # you can change default, required, coerce, documentation, lazy, handles, builder, metaclass and traits
     my %actual_options;
-    foreach my $legal_option (qw(default coerce required documentation lazy handles builder)) {
+    foreach my $legal_option (qw(default coerce required documentation lazy handles builder metaclass traits)) {
         if (exists $options{$legal_option}) {
             $actual_options{$legal_option} = $options{$legal_option};
             delete $options{$legal_option};
@@ -78,9 +116,7 @@ sub clone_and_inherit_options {
             $type_constraint = $options{isa};
         }
         else {
-            # FIXME this causes a failing test, not sure it should
-            # $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
-            $type_constraint = Moose::Util::TypeConstraints::find_or_parse_type_constraint($options{isa});
+            $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
             (defined $type_constraint)
                 || confess "Could not find the type constraint '" . $options{isa} . "'";
         }
@@ -95,9 +131,7 @@ sub clone_and_inherit_options {
             $type_constraint = $options{does};
         }
         else {
-            # FIXME see above
-            # $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
-            $type_constraint = Moose::Util::TypeConstraints::find_or_parse_type_constraint($options{does});
+            $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
             (defined $type_constraint)
                 || confess "Could not find the type constraint '" . $options{does} . "'";
         }
@@ -609,6 +643,13 @@ creation and type coercion.
 
 =over 4
 
+=item B<interpolate_class_and_new>
+
+=item B<interpolate_class>
+
+When called as a class method causes interpretation of the C<metaclass> and
+C<traits> options.
+
 =item B<clone_and_inherit_options>
 
 This is to support the C<has '+foo'> feature, it clones an attribute
@@ -708,6 +749,15 @@ in some kind of automated documentation system perhaps.
 
 Returns true if this meta-attribute has any documentation.
 
+=item B<applied_traits>
+
+This will return the ARRAY ref of all the traits applied to this 
+attribute, or if no traits have been applied, it returns C<undef>.
+
+=item B<has_applied_traits>
+
+Returns true if this meta-attribute has any traits applied.
+
 =back
 
 =head1 BUGS