From: Yuval Kogman <nothingmuch@woobling.org>
Date: Thu, 24 Apr 2008 21:31:37 +0000 (+0000)
Subject: support traits/metaclasses in clone_and_inherit_whatever_id_dont_remember_the_name_of... 
X-Git-Tag: 0_55~210
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c32c2c61eb96d01d5e41f479b191c5f62b9b798d;p=gitmo%2FMoose.git

support traits/metaclasses in clone_and_inherit_whatever_id_dont_remember_the_name_of_the_method_fuck_im_tired_goddamn_hippy_technology_we_hates_it
---

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 0bd227a..7ff7596 100644
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -62,48 +62,62 @@ __PACKAGE__->meta->add_attribute('traits' => (
 
 sub new {
     my ($class, $name, %options) = @_;
-    $class->_process_options($name, \%options);
+    $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
     return $class->SUPER::new($name, %options);
 }
 
 sub interpolate_class_and_new {
     my ($class, $name, @args) = @_;
 
-    $class->interpolate_class(@args)->new($name, @args);
+    my ( $new_class, @traits ) = $class->interpolate_class(@args);
+    
+    $new_class->new($name, @args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
 }
 
 sub interpolate_class {
     my ($class, %options) = @_;
 
-    if ( my $metaclass_name = $options{metaclass} ) {
-        $class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
+    $class = ref($class) || $class;
+
+    if ( my $metaclass_name = delete $options{metaclass} ) {
+        my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
+        
+        if ( $class ne $new_class ) {
+            if ( $new_class->can("interpolate_class") ) {
+                return $new_class->interpolate_class(%options);
+            } else {
+                $class = $new_class;
+            }
+        }
     }
 
+    my @traits;
+
     if (my $traits = $options{traits}) {
-        my @traits = map {
+        if ( @traits = grep { not $class->does($_) } 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;
+        } @$traits ) {
+            my $anon_class = Moose::Meta::Class->create_anon_class(
+                superclasses => [ $class ],
+                roles        => [ @traits ],
+                cache        => 1,
+            );
+
+            $class = $anon_class->name;
+        }
     }
+
+    return ( wantarray ? ( $class, @traits ) : $class );
 }
 
 sub clone_and_inherit_options {
     my ($self, %options) = @_;
-    # you can change default, required, coerce, documentation, lazy, handles, builder, metaclass and traits
+    my %copy = %options;
+    # you can change default, required, coerce, documentation, lazy, handles, builder, type_constraint (explicitly or using isa/does), metaclass and traits
     my %actual_options;
-    foreach my $legal_option (qw(default coerce required documentation lazy handles builder metaclass traits)) {
+    foreach my $legal_option (qw(default coerce required documentation lazy handles builder type_constraint)) {
         if (exists $options{$legal_option}) {
             $actual_options{$legal_option} = $options{$legal_option};
             delete $options{$legal_option};
@@ -139,12 +153,51 @@ sub clone_and_inherit_options {
         $actual_options{type_constraint} = $type_constraint;
         delete $options{does};
     }    
-    
+
+    ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(%options);
+
+    my %seen;
+    my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
+    $actual_options{traits} = \@all_traits if @all_traits;
+
+    delete @options{qw(metaclass traits)};
+
     (scalar keys %options == 0)
         || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
+
+
     $self->clone(%actual_options);
 }
 
+sub clone {
+    my ( $self, %params ) = @_;
+
+    my $class = $params{metaclass} || ref $self;
+
+    if ( 0 and $class eq ref $self ) {
+        return $self->SUPER::clone(%params);
+    } else {
+        my ( @init, @non_init );
+
+        foreach my $attr ( grep { $_->has_value($self) } $self->meta->compute_all_applicable_attributes ) {
+            push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
+        }
+
+        my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
+
+        my $name = delete $new_params{name};
+
+        my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
+
+        foreach my $attr ( @non_init ) {
+            $attr->set_value($clone, $attr->get_value($self));
+        }
+
+
+        return $clone;
+    }
+}
+
 sub _process_options {
     my ($class, $name, $options) = @_;
 
@@ -603,6 +656,8 @@ will behave just as L<Class::MOP::Attribute> does.
 
 =item B<new>
 
+=item B<clone>
+
 =item B<does>
 
 =item B<initialize_instance_slot>
diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index c591374..f113d88 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -157,7 +157,7 @@ sub construct_instance {
     # have to kludge it in the end.
     my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
     foreach my $attr ($class->compute_all_applicable_attributes()) {
-        $attr->initialize_instance_slot($meta_instance, $instance, \%params)
+        $attr->initialize_instance_slot($meta_instance, $instance, \%params);
     }
     return $instance;
 }
diff --git a/t/020_attributes/009_attribute_inherited_slot_specs.t b/t/020_attributes/009_attribute_inherited_slot_specs.t
index 0f1c33c..7f3b859 100644
--- a/t/020_attributes/009_attribute_inherited_slot_specs.t
+++ b/t/020_attributes/009_attribute_inherited_slot_specs.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 85;
+use Test::More tests => 83;
 use Test::Exception;
 
 BEGIN {
@@ -86,14 +86,6 @@ BEGIN {
     } '... now can extend an attribute with a non-subtype';    
 
     ::lives_ok {
-        has '+foo' => ( metaclass => 'DoNotSerialize' ); 
-    } 'Can add metaclass attribute option';
-
-    ::lives_ok {
-        has '+foo' => ( traits => [ 'DoNotSerialize' ] );
-    } 'Can add traits attribute option';   
- 
-    ::lives_ok {
         has '+bling' => (handles => ['hello']);        
     } '... we can add the handles attribute option';
     
diff --git a/t/020_attributes/016_attribute_traits_registered.t b/t/020_attributes/016_attribute_traits_registered.t
index ad4aa84..726ed04 100644
--- a/t/020_attributes/016_attribute_traits_registered.t
+++ b/t/020_attributes/016_attribute_traits_registered.t
@@ -39,7 +39,7 @@ BEGIN {
         42;
     };
 
-    has bar => ( isa => "Str", default => "oink" );
+    has the_other_attr => ( isa => "Str", is => "rw", default => "oink" );
 
     after 'install_accessors' => sub {
         my $self = shift;
@@ -100,12 +100,10 @@ does_ok($derived_bar_attr, 'My::Attribute::Trait' );
 
 is( $derived_bar_attr->foo, "blah", "attr initialized" );
 
-TODO: {
-    local $TODO = 'traits in clone_and_inherit dont work yet';
-    does_ok($derived_bar_attr, 'My::Other::Attribute::Trait' );
+does_ok($derived_bar_attr, 'My::Other::Attribute::Trait' );
 
-    is( eval { $derived_bar_attr->bar }, "oink", "attr initialized" );
+is($derived_bar_attr->the_other_attr, "oink", "attr initialized" );
+
+can_ok($quux, 'additional_method');
+is(eval { $quux->additional_method }, 42, '... got the right value for additional_method');
 
-    can_ok($quux, 'additional_method');
-    is(eval { $quux->additional_method }, 42, '... got the right value for additional_method');
-}