From: Jesse Luehrs <doy@tozt.net>
Date: Wed, 20 Oct 2010 23:20:58 +0000 (-0500)
Subject: factor codegen stuff out to Eval::Closure
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=15961c86cfd845e6f46b6c362cc1a4b94ffb45db;p=gitmo%2FClass-MOP.git

factor codegen stuff out to Eval::Closure
---

diff --git a/Makefile.PL b/Makefile.PL
index be7b8e1..0b0c7a3 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -22,6 +22,7 @@ if ( -d '.git' || $ENV{MAINTAINER_MODE} ) {
 requires 'Carp';
 requires 'Data::OptList';
 requires 'Devel::GlobalDestruction';
+requires 'Eval::Closure';
 requires 'List::MoreUtils'             => '0.12';
 requires 'MRO::Compat'                 => '0.05';
 requires 'Package::DeprecationManager' => '0.10';
diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm
index 5ba0f3d..b4377e9 100644
--- a/lib/Class/MOP/Method/Accessor.pm
+++ b/lib/Class/MOP/Method/Accessor.pm
@@ -6,6 +6,7 @@ use warnings;
 
 use Carp         'confess';
 use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
 
 our $VERSION   = '1.11';
 $VERSION = eval $VERSION;
@@ -133,14 +134,20 @@ sub _generate_accessor_method_inline {
     my $self = shift;
     my $attr = $self->associated_attribute;
 
-    my ( $code, $e ) = $self->_eval_closure(
-        {},
-        'sub {'
-            . $attr->inline_set( '$_[0]', '$_[1]' )
-            . ' if scalar(@_) == 2; '
-            . $attr->inline_get('$_[0]') . '}'
-    );
-    confess "Could not generate inline accessor because : $e" if $e;
+    my $code = try {
+        $self->_compile_code(
+            source => [
+                'sub {',
+                    $attr->inline_set( '$_[0]', '$_[1]' )
+                        . ' if scalar(@_) == 2;',
+                    $attr->inline_get('$_[0]') . ';',
+                '}',
+            ]
+        );
+    }
+    catch {
+        confess "Could not generate inline accessor because : $_";
+    };
 
     return $code;
 }
@@ -149,13 +156,20 @@ sub _generate_reader_method_inline {
     my $self = shift;
     my $attr = $self->associated_attribute;
 
-    my ( $code, $e ) = $self->_eval_closure(
-        {},
-        'sub {'
-            . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
-            . $attr->inline_get('$_[0]') . '}'
-    );
-    confess "Could not generate inline reader because : $e" if $e;
+    my $code = try {
+        $self->_compile_code(
+            source => [
+                'sub {',
+                    'confess "Cannot assign a value to a read-only accessor" '
+                        . 'if @_ > 1;',
+                    $attr->inline_get('$_[0]') . ';',
+                '}',
+            ],
+        );
+    }
+    catch {
+        confess "Could not generate inline reader because : $_";
+    };
 
     return $code;
 }
@@ -164,11 +178,18 @@ sub _generate_writer_method_inline {
     my $self = shift;
     my $attr = $self->associated_attribute;
 
-    my ( $code, $e ) = $self->_eval_closure(
-        {},
-        'sub {' . $attr->inline_set( '$_[0]', '$_[1]' ) . '}'
-    );
-    confess "Could not generate inline writer because : $e" if $e;
+    my $code = try {
+        $self->_compile_code(
+            source => [
+                'sub {',
+                    $attr->inline_set( '$_[0]', '$_[1]' ) . ';',
+                '}',
+            ],
+        );
+    }
+    catch {
+        confess "Could not generate inline writer because : $_";
+    };
 
     return $code;
 }
@@ -177,11 +198,18 @@ sub _generate_predicate_method_inline {
     my $self = shift;
     my $attr = $self->associated_attribute;
 
-    my ( $code, $e ) = $self->_eval_closure(
-        {},
-        'sub {' . $attr->inline_has('$_[0]') . '}'
-    );
-    confess "Could not generate inline predicate because : $e" if $e;
+    my $code = try {
+        $self->_compile_code(
+            source => [
+                'sub {',
+                    $attr->inline_has('$_[0]') . ';',
+                '}',
+            ],
+        );
+    }
+    catch {
+        confess "Could not generate inline predicate because : $_";
+    };
 
     return $code;
 }
@@ -190,11 +218,18 @@ sub _generate_clearer_method_inline {
     my $self = shift;
     my $attr = $self->associated_attribute;
 
-    my ( $code, $e ) = $self->_eval_closure(
-        {},
-        'sub {' . $attr->inline_clear('$_[0]') . '}'
-    );
-    confess "Could not generate inline clearer because : $e" if $e;
+    my $code = try {
+        $self->_compile_code(
+            source => [
+                'sub {',
+                    $attr->inline_clear('$_[0]') . ';',
+                '}',
+            ],
+        );
+    }
+    catch {
+        confess "Could not generate inline clearer because : $_";
+    };
 
     return $code;
 }
diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm
index d614587..05c8d92 100644
--- a/lib/Class/MOP/Method/Constructor.pm
+++ b/lib/Class/MOP/Method/Constructor.pm
@@ -6,6 +6,7 @@ use warnings;
 
 use Carp         'confess';
 use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
 
 our $VERSION   = '1.11';
 $VERSION = eval $VERSION;
@@ -121,11 +122,15 @@ sub _generate_constructor_method_inline {
     $source .= ";\n" . '}';
     warn $source if $self->options->{debug};
 
-    my ( $code, $e ) = $self->_eval_closure(
-        $close_over,
-        $source
-    );
-    confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e" if $e;
+    my $code = try {
+        $self->_compile_code(
+            source => $source,
+            environment => $close_over,
+        );
+    }
+    catch {
+        confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$_";
+    };
 
     return $code;
 }
diff --git a/lib/Class/MOP/Method/Generated.pm b/lib/Class/MOP/Method/Generated.pm
index cb4b1b0..abdeb65 100644
--- a/lib/Class/MOP/Method/Generated.pm
+++ b/lib/Class/MOP/Method/Generated.pm
@@ -5,6 +5,7 @@ use strict;
 use warnings;
 
 use Carp 'confess';
+use Eval::Closure;
 
 our $VERSION   = '1.11';
 $VERSION = eval $VERSION;
@@ -22,97 +23,36 @@ sub _initialize_body {
     confess "No body to initialize, " . __PACKAGE__ . " is an abstract base class";
 }
 
-sub _eval_closure {
-    my ($self, $__captures, $sub_body) = @_;
-
-    my $code;
-
-    my $e = do {
-        local $@;
-        local $SIG{__DIE__};
-        my $source = join
-            "\n", (
-            map {
-                /^([\@\%\$])/
-                    or die "capture key should start with \@, \% or \$: $_";
-                q[my ] 
-                    . $_ . q[ = ] 
-                    . $1
-                    . q[{$__captures->{']
-                    . $_ . q['}};];
-                } keys %$__captures
-            ),
-            $sub_body;
-
-        $self->_dump_source($source) if $ENV{MOP_PRINT_SOURCE};
-
-        $code = eval $source;
-        $@;
-    };
-
-    return ( $code, $e );
-}
-
-sub _dump_source {
-    my ( $self, $source ) = @_;
-
-    my $output;
-    if ( eval { require Perl::Tidy } ) {
-        require File::Spec;
-
-        my $rc_file = File::Spec->catfile(
-            $INC{'Class/MOP/Method/Generated.pm'},
-            ('..') x 5,
-            'perltidyrc'
-        );
-
-        my %p = (
-            source      => \$source,
-            destination => \$output,
-        );
-        $p{perltidyrc} = $rc_file
-            if -f $rc_file;
-
-        Perl::Tidy::perltidy(%p);
-    }
-    else {
-        $output = $source;
-    }
+sub _generate_description {
+    my ( $self, $context ) = @_;
+    $context ||= $self->definition_context;
 
-    print STDERR "\n", $self->name, ":\n", $output, "\n";
-}
-
-sub _add_line_directive {
-    my ( $self, %args ) = @_;
+    return "generated method (unknown origin)"
+        unless defined $context;
 
-    my ( $line, $file );
-
-    if ( my $ctx = ( $args{context} || $self->definition_context ) ) {
-        $line = $ctx->{line};
-        if ( my $desc = $ctx->{description} ) {
-            $file = "$desc defined at $ctx->{file}";
-        } else {
-            $file = $ctx->{file};
-        }
+    if (defined $context->{description}) {
+        return "$context->{description} "
+             . "(defined at $context->{file} line $context->{line})";
     } else {
-        ( $line, $file ) = ( 0, "generated method (unknown origin)" );
+        return "$context->{file} (line $context->{line})";
     }
-
-    my $code = $args{code};
-
-    # if it's an array of lines, join it up
-    # don't use newlines so that the definition context is more meaningful
-    $code = join(@$code, ' ') if ref $code;
-
-    return qq{#line $line "$file"\n} . $code;
 }
 
 sub _compile_code {
-    my ( $self, %args ) = @_;
-
-    my $code = $self->_add_line_directive(%args);
-
-    return $self->_eval_closure($args{environment}, $code);
+    my ( $self, @args ) = @_;
+    unshift @args, 'source' if @args % 2;
+    my %args = @args;
+
+    my $context = delete $args{context};
+    my $environment = $self->can('_eval_environment')
+        ? $self->_eval_environment
+        : {};
+
+    return eval_closure(
+        environment => $environment,
+        description => $self->_generate_description($context),
+        %args,
+    );
 }
 
 1;
diff --git a/t/310_inline_structor.t b/t/310_inline_structor.t
index a1f3e64..04732d2 100644
--- a/t/310_inline_structor.t
+++ b/t/310_inline_structor.t
@@ -200,8 +200,7 @@ use Class::MOP;
     sub _inline_destructor {
         my $self = shift;
 
-        my ( $code, $e ) = $self->_eval_closure( {}, 'sub { }' );
-        die $e if $e;
+        my $code = $self->_compile_code(source => 'sub { }');
 
         $self->{body} = $code;
     }