From: Dave Rolsky <autarch@urth.org>
Date: Wed, 15 Sep 2010 17:02:26 +0000 (-0500)
Subject: Put curried args into closed-over environment.
X-Git-Tag: 1.15~152
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f5f08b5fc95e602afbd05df3d6e852541ee0ffd1;p=gitmo%2FMoose.git

Put curried args into closed-over environment.

Fix first to do what it's supposed to.

Just push curried args onto the front of @_ for simplicity.
---

diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm
index 12d2ddc..84e7b13 100644
--- a/lib/Moose/Meta/Method/Accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor.pm
@@ -19,20 +19,8 @@ sub _error_thrower {
 sub _eval_code {
     my ( $self, $source ) = @_;
 
-    # NOTE:
-    # set up the environment
-    my $attr = $self->associated_attribute;
-    my $type_constraint_obj = $attr->type_constraint;
-    my $environment = {
-        '$attr' => \$attr,
-        '$meta' => \$self,
-        '$type_constraint_obj' => \$type_constraint_obj,
-        '$type_constraint' => \($type_constraint_obj
-                                   ? $type_constraint_obj->_compiled_type_constraint
-                                   : undef),
-    };
+    my $environment = $self->_eval_environment;
 
-    #warn "code for " . $attr->name . " =>\n" . $source . "\n";
     my ( $code, $e ) = $self->_compile_code( environment => $environment, code => $source );
 
     $self->throw_error(
@@ -43,6 +31,24 @@ sub _eval_code {
     return $code;
 }
 
+sub _eval_environment {
+    my $self = shift;
+
+    my $attr                = $self->associated_attribute;
+    my $type_constraint_obj = $attr->type_constraint;
+
+    return {
+        '$attr'                => \$attr,
+        '$meta'                => \$self,
+        '$type_constraint_obj' => \$type_constraint_obj,
+        '$type_constraint'     => \(
+              $type_constraint_obj
+            ? $type_constraint_obj->_compiled_type_constraint
+            : undef
+        ),
+    };
+}
+
 sub _generate_accessor_method_inline {
     my $self        = $_[0];
     my $attr        = $self->associated_attribute;
diff --git a/lib/Moose/Meta/Method/Accessor/Native.pm b/lib/Moose/Meta/Method/Accessor/Native.pm
index 77fc6b9..17f6a46 100644
--- a/lib/Moose/Meta/Method/Accessor/Native.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native.pm
@@ -40,6 +40,8 @@ sub new {
 
     $options{delegate_to_method} = lc( ( split /::/, $class)[-1] );
 
+    $options{definition_context} = $options{attribute}->definition_context;
+
     my $self = $class->_new( \%options );
 
     weaken( $self->{'attribute'} );
@@ -64,4 +66,14 @@ sub _initialize_body {
     return;
 }
 
+sub _eval_environment {
+    my $self = shift;
+
+    my $env = $self->SUPER::_eval_environment;
+
+    $env->{'@curried'} = $self->curried_arguments;
+
+    return $env;
+}
+
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array.pm b/lib/Moose/Meta/Method/Accessor/Native/Array.pm
index 13ef392..0380f59 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array.pm
@@ -12,22 +12,12 @@ our $AUTHORITY = 'cpan:STEVAN';
 
 use base 'Moose::Meta::Method::Accessor::Native';
 
-sub _value_needs_copy {
+sub _inline_curried_arguments {
     my $self = shift;
 
-    return @{ $self->curried_arguments };
-}
-
-sub _inline_copy_value {
-    my $self = shift;
-
-    return q{} unless $self->_value_needs_copy;
-
-    my $curry = join ', ',
-        map { looks_like_number($_) ? $_ : B::perlstring($_) }
-        @{ $self->curried_arguments };
+    return q{} unless @{ $self->curried_arguments };
 
-    return "my \@val = ( $curry, \@_ );";
+    return "\@_ = ( \@curried, \@_ );";
 }
 
 sub _inline_check_constraint {
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm
index 04d8799..d92bb74 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm
@@ -18,6 +18,7 @@ sub _generate_method {
     $code .= "\n" . $self->_inline_pre_body(@_);
 
     $code .= "\n" . 'my $self = shift;';
+    $code .= "\n" . $self->_inline_curried_arguments;
     $code .= "\n" . $self->_inline_process_arguments;
 
     $code
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm
index 007a9f0..91c3369 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm
@@ -3,17 +3,23 @@ package Moose::Meta::Method::Accessor::Native::Array::first;
 use strict;
 use warnings;
 
+use List::Util ();
+
 our $VERSION = '1.13';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
 use base 'Moose::Meta::Method::Accessor::Native::Array::Reader';
 
+sub _inline_process_arguments {
+    return 'my $func = shift;';
+}
+
 sub _return_value {
     my $self        = shift;
     my $slot_access = shift;
 
-    return "${slot_access}->[0]";
+    return "&List::Util::first( \$func, \@{ ${slot_access} } )";
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm
index bf7b3aa..b567cac 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm
@@ -16,11 +16,6 @@ sub _generate_method {
 
     my $slot_access = $self->_inline_get($inv);
 
-    my $value_name
-        = $self->_value_needs_copy
-        ? '@val'
-        : '@_';
-
     my $code = 'sub {';
     $code .= "\n" . $self->_inline_pre_body(@_);
 
@@ -28,33 +23,33 @@ sub _generate_method {
 
     $code .= "\n" . $self->_inline_check_lazy($inv);
 
-    $code .= "\n" . $self->_inline_copy_value;
+    $code .= "\n" . $self->_inline_curried_arguments;
 
     $code
         .= "\n"
         . $self->_inline_throw_error(
         q{"Cannot call push without any arguments"})
-        . " unless $value_name;";
+        . " unless \@_;";
 
     my $potential_new_val;
     if ( $self->_constraint_must_be_checked ) {
-        $code .= "\n" . "my \@new_val = ( \@{ $slot_access }, $value_name );";
+        $code .= "\n" . "my \@new_val = ( \@{ $slot_access }, \@_ );";
         $potential_new_val = '\\@new_val';
     }
     else {
-        $potential_new_val = "[ \@{ $slot_access }, $value_name ];";
+        $potential_new_val = "[ \@{ $slot_access }, \@_ ];";
     }
 
     $code .= "\n" . $self->_inline_check_coercion($potential_new_val);
     $code .= "\n" . $self->_inline_check_constraint($potential_new_val);
 
     $code .= "\n"
-        . $self->_inline_get_old_value_for_trigger( $inv, $value_name );
+        . $self->_inline_get_old_value_for_trigger( $inv, '@_' );
 
     $code .= "\n" . $self->_inline_store( $inv, $potential_new_val );
 
     $code .= "\n" . $self->_inline_post_body(@_);
-    $code .= "\n" . $self->_inline_trigger( $inv, $value_name, '@old' );
+    $code .= "\n" . $self->_inline_trigger( $inv, '@_', '@old' );
 
     $code .= "\n}";