From: Jesse Luehrs <doy@tozt.net>
Date: Fri, 17 Jun 2011 22:28:57 +0000 (-0500)
Subject: move eval_environment for constructors to the metaclass
X-Git-Tag: 2.0102~7
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=96fec63368aadd66c72d692173f673f1cf21c32f;p=gitmo%2FMoose.git

move eval_environment for constructors to the metaclass
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 267e376..a7c3ca3 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -695,6 +695,18 @@ sub _inline_preserve_weak_metaclasses {
 
 sub _inline_extra_init { }
 
+sub _eval_environment {
+    my $self = shift;
+
+    my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
+
+    my $defaults = [map { $_->default } @attrs];
+
+    return {
+        '$defaults' => \$defaults,
+    };
+}
+
 
 sub get_meta_instance {
     my $self = shift;
diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm
index 8a35df8..0b4ef7d 100644
--- a/lib/Class/MOP/Method/Constructor.pm
+++ b/lib/Class/MOP/Method/Constructor.pm
@@ -67,16 +67,6 @@ sub _new {
 sub options              { (shift)->{'options'}              }
 sub associated_metaclass { (shift)->{'associated_metaclass'} }
 
-## cached values ...
-
-sub _attributes {
-    my $self = shift;
-    $self->{'attributes'} ||= [
-        sort { $a->name cmp $b->name }
-             $self->associated_metaclass->get_all_attributes
-    ]
-}
-
 ## method
 
 sub _initialize_body {
@@ -90,10 +80,7 @@ sub _initialize_body {
 
 sub _eval_environment {
     my $self = shift;
-    my $defaults = [map { $_->default } @{ $self->_attributes }];
-    return {
-        '$defaults' => \$defaults,
-    };
+    return $self->associated_metaclass->_eval_environment;
 }
 
 sub _generate_constructor_method {
diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index f0f6253..57d76f5 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -479,6 +479,63 @@ sub _inline_BUILDALL {
     return @BUILD_calls;
 }
 
+sub _eval_environment {
+    my $self = shift;
+
+    my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
+
+    my $triggers = [
+        map { $_->can('has_trigger') && $_->has_trigger ? $_->trigger : undef }
+            @attrs
+    ];
+
+    # We need to check if the attribute ->can('type_constraint')
+    # since we may be trying to immutabilize a Moose meta class,
+    # which in turn has attributes which are Class::MOP::Attribute
+    # objects, rather than Moose::Meta::Attribute. And
+    # Class::MOP::Attribute attributes have no type constraints.
+    # However we need to make sure we leave an undef value there
+    # because the inlined code is using the index of the attributes
+    # to determine where to find the type constraint
+
+    my @type_constraints = map {
+        $_->can('type_constraint') ? $_->type_constraint : undef
+    } @attrs;
+
+    my @type_constraint_bodies = map {
+        defined $_ ? $_->_compiled_type_constraint : undef;
+    } @type_constraints;
+
+    my @type_coercions = map {
+        defined $_ && $_->has_coercion
+            ? $_->coercion->_compiled_type_coercion
+            : undef
+    } @type_constraints;
+
+    my @type_constraint_messages = map {
+        defined $_
+            ? ($_->has_message ? $_->message : $_->_default_message)
+            : undef
+    } @type_constraints;
+
+    return {
+        %{ $self->SUPER::_eval_environment },
+        ((any { defined && $_->has_initializer } @attrs)
+            ? ('$attrs' => \[@attrs])
+            : ()),
+        '$triggers' => \$triggers,
+        '@type_coercions' => \@type_coercions,
+        '@type_constraint_bodies' => \@type_constraint_bodies,
+        '@type_constraint_messages' => \@type_constraint_messages,
+        ( map { defined($_) ? %{ $_->inline_environment } : () }
+              @type_constraints ),
+        # pretty sure this is only going to be closed over if you use a custom
+        # error class at this point, but we should still get rid of this
+        # at some point
+        '$meta'  => \$self,
+    };
+}
+
 sub superclasses {
     my $self = shift;
     my $supers = Data::OptList::mkopt(\@_);
diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index ad19406..e20c424 100644
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -51,64 +51,6 @@ sub _initialize_body {
     $self->{'body'} = $self->_generate_constructor_method_inline;
 }
 
-sub _eval_environment {
-    my $self = shift;
-
-    my $attrs = $self->_attributes;
-
-    my $defaults = [map { $_->default } @$attrs];
-    my $triggers = [
-        map { $_->can('has_trigger') && $_->has_trigger ? $_->trigger : undef }
-            @$attrs
-    ];
-
-    # We need to check if the attribute ->can('type_constraint')
-    # since we may be trying to immutabilize a Moose meta class,
-    # which in turn has attributes which are Class::MOP::Attribute
-    # objects, rather than Moose::Meta::Attribute. And
-    # Class::MOP::Attribute attributes have no type constraints.
-    # However we need to make sure we leave an undef value there
-    # because the inlined code is using the index of the attributes
-    # to determine where to find the type constraint
-
-    my @type_constraints = map {
-        $_->can('type_constraint') ? $_->type_constraint : undef
-    } @$attrs;
-
-    my @type_constraint_bodies = map {
-        defined $_ ? $_->_compiled_type_constraint : undef;
-    } @type_constraints;
-
-    my @type_coercions = map {
-        defined $_ && $_->has_coercion
-            ? $_->coercion->_compiled_type_coercion
-            : undef
-    } @type_constraints;
-
-    my @type_constraint_messages = map {
-        defined $_
-            ? ($_->has_message ? $_->message : $_->_default_message)
-            : undef
-    } @type_constraints;
-
-    return {
-        ((any { defined && $_->has_initializer } @$attrs)
-            ? ('$attrs' => \$attrs)
-            : ()),
-        '$defaults' => \$defaults,
-        '$triggers' => \$triggers,
-        '@type_coercions' => \@type_coercions,
-        '@type_constraint_bodies' => \@type_constraint_bodies,
-        '@type_constraint_messages' => \@type_constraint_messages,
-        ( map { defined($_) ? %{ $_->inline_environment } : () }
-              @type_constraints ),
-        # pretty sure this is only going to be closed over if you use a custom
-        # error class at this point, but we should still get rid of this
-        # at some point
-        '$meta'  => \($self->associated_metaclass),
-    };
-}
-
 1;
 
 # ABSTRACT: Method Meta Object for constructors
diff --git a/t/cmop/self_introspection.t b/t/cmop/self_introspection.t
index e6d00f6..7fd0933 100644
--- a/t/cmop/self_introspection.t
+++ b/t/cmop/self_introspection.t
@@ -74,6 +74,7 @@ my @class_mop_class_methods = qw(
     _inline_generate_instance _inline_params _inline_slot_initializers
     _inline_init_attr_from_constructor _inline_init_attr_from_default
     _generate_fallback_constructor
+    _eval_environment
     construct_instance _construct_instance
     construct_class_instance _construct_class_instance
     clone_instance _clone_instance