stop closing over the method metaobject

changed this to close over the class metaobject if we're using a custom
error class, but there's no real way around that. the whole error system
really needs to be thrown out and redone anyway.

diff --git a/lib/Moose/Error/Confess.pm b/lib/Moose/Error/Confess.pm
index eaf6120..358be9a 100644 (file)
--- a/lib/Moose/Error/Confess.pm
+++ b/lib/Moose/Error/Confess.pm
@@ -10,6 +10,12 @@ sub new {
     $self->create_error_confess(@args);
 }
 
+sub _inline_new {
+    my ( $self, @args ) = @_;
+
+    return $self->_inline_create_error_carpmess(@args, longmess => 1);
+}
+
 1;
 
 # ABSTRACT: Prefer C<confess>

diff --git a/lib/Moose/Error/Croak.pm b/lib/Moose/Error/Croak.pm
index 0c8b04c..9917b96 100644 (file)
--- a/lib/Moose/Error/Croak.pm
+++ b/lib/Moose/Error/Croak.pm
@@ -10,6 +10,12 @@ sub new {
     $self->create_error_croak(@args);
 }
 
+sub _inline_new {
+    my ( $self, @args ) = @_;
+
+    return $self->_inline_create_error_carpmess(@args);
+}
+
 1;
 
 # ABSTRACT: Prefer C<croak>

diff --git a/lib/Moose/Error/Default.pm b/lib/Moose/Error/Default.pm
index 47c0024..d3673f0 100644 (file)
--- a/lib/Moose/Error/Default.pm
+++ b/lib/Moose/Error/Default.pm
@@ -20,6 +20,16 @@ sub new {
     }
 }
 
+sub _inline_new {
+    my ( $self, @args ) = @_;
+
+    return '(do { '
+             . '(defined $ENV{MOOSE_ERROR_STYLE} && $ENV{MOOSE_ERROR_STYLE} eq "croak"'
+               . ' ? ' . $self->_inline_create_error_carpmess(@args)
+               . ' : ' . $self->_inline_create_error_carpmess(@args, longmess => 1)
+         . ')})';
+}
+
 sub create_error_croak {
     my ( $self, @args ) = @_;
     $self->_create_error_carpmess( @args );
@@ -46,6 +56,31 @@ sub _create_error_carpmess {
     }
 }
 
+sub _inline_create_error_carpmess {
+    my ( $self, %args ) = @_;
+
+    my $carp_level = $args{depth} || 0;
+
+    my $create_message = 'Carp::longmess(' . $args{message} . ')';
+
+    if (!$args{longmess}) {
+        $create_message =
+            '($Carp::Verbose '
+              . '? ' . $create_message . ' '
+              . ': Carp::ret_summary('
+                  . $carp_level . ', ' . $args{message}
+              . '))';
+    }
+
+    return
+        '(do { '
+          . 'local $Carp::MaxArgNums = 20; '
+          . 'local $Carp::CarpLevel = ($Carp::CarpLevel || 0) + '
+              . $carp_level . '; '
+          . $create_message
+      . '})';
+}
+
 1;
 
 # ABSTRACT: L<Carp> based error generation for Moose.

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index e6d5172..20d8a79 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -40,19 +40,40 @@ sub does {
     return $self->Moose::Object::does($name);
 }
 
+sub _error_thrower {
+    my $self = shift;
+    require Moose::Meta::Class;
+    ( ref $self && $self->associated_class ) || "Moose::Meta::Class";
+}
+
 sub throw_error {
     my $self = shift;
-    my $class = ( ref $self && $self->associated_class ) || "Moose::Meta::Class";
+    my $inv = $self->_error_thrower;
     unshift @_, "message" if @_ % 2 == 1;
     unshift @_, attr => $self if ref $self;
-    unshift @_, $class;
-    my $handler = $class->can("throw_error"); # to avoid incrementing depth by 1
+    unshift @_, $inv;
+    my $handler = $inv->can("throw_error"); # to avoid incrementing depth by 1
     goto $handler;
 }
 
 sub _inline_throw_error {
     my ( $self, $msg, $args ) = @_;
-    "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
+
+    my $inv = $self->_error_thrower;
+    # XXX ugh
+    $inv = 'Moose::Meta::Class' unless $inv->can('_inline_throw_error');
+
+    # XXX ugh ugh UGH
+    my $class = $self->associated_class;
+    if ($class) {
+        my $class_name = B::perlstring($class->name);
+        my $attr_name = B::perlstring($self->name);
+        $args = 'attr => Class::MOP::class_of(' . $class_name . ')'
+              . '->find_attribute_by_name(' . $attr_name . '), '
+              . (defined $args ? $args : '');
+    }
+
+    return $inv->_inline_throw_error($msg, $args)
 }
 
 sub new {

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index e7b9da2..821902e 100644 (file)
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -690,8 +690,8 @@ sub throw_error {
 }
 
 sub _inline_throw_error {
-    my ( $self, $msg, $args ) = @_;
-    "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
+    my ( $self, @args ) = @_;
+    $self->_inline_raise_error($self->_inline_create_error(@args));
 }
 
 sub raise_error {
@@ -699,6 +699,14 @@ sub raise_error {
     die @args;
 }
 
+sub _inline_raise_error {
+    my ( $self, $message ) = @_;
+
+    return (
+        'die ' . $message . ';',
+    );
+}
+
 sub create_error {
     my ( $self, @args ) = @_;
 
@@ -724,6 +732,36 @@ sub create_error {
     );
 }
 
+sub _inline_create_error {
+    my ( $self, $msg, $args ) = @_;
+    # XXX ignore $args for now, nothing currently uses it anyway
+
+    require Carp::Heavy;
+
+    my %args = (
+        metaclass  => $self,
+        last_error => $@,
+        message    => $msg,
+    );
+
+    my $class = ref $self ? $self->error_class : "Moose::Error::Default";
+
+    Class::MOP::load_class($class);
+
+    # don't check inheritance here - the intention is that the class needs
+    # to provide a non-inherited inlining method, because falling back to
+    # the default inlining method is most likely going to be wrong
+    # yes, this is a huge hack, but so is the entire error system, so.
+    return '$meta->create_error(' . $msg . ', ' . $args . ');'
+        unless $class->meta->has_method('_inline_new');
+
+    $class->_inline_new(
+        # XXX ignore this for now too
+        # Carp::caller_info($args{depth}),
+        %args
+    );
+}
+
 1;
 
 # ABSTRACT: The Moose metaclass

diff --git a/lib/Moose/Meta/Method.pm b/lib/Moose/Meta/Method.pm
index 1488c32..74cbe8d 100644 (file)
--- a/lib/Moose/Meta/Method.pm
+++ b/lib/Moose/Meta/Method.pm
@@ -11,6 +11,7 @@ Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
 
 sub _error_thrower {
     my $self = shift;
+    require Moose::Meta::Class;
     ( ref $self && $self->associated_metaclass ) || "Moose::Meta::Class";
 }
 
@@ -26,7 +27,22 @@ sub throw_error {
 
 sub _inline_throw_error {
     my ( $self, $msg, $args ) = @_;
-    "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
+
+    my $inv = $self->_error_thrower;
+    # XXX ugh
+    $inv = 'Moose::Meta::Class' unless $inv->can('_inline_throw_error');
+
+    # XXX ugh ugh UGH
+    my $class = $self->associated_metaclass;
+    if ($class) {
+        my $class_name = B::perlstring($class->name);
+        my $meth_name = B::perlstring($self->name);
+        $args = 'method => Class::MOP::class_of(' . $class_name . ')'
+              . '->find_method_by_name(' . $meth_name . '), '
+              . (defined $args ? $args : '');
+    }
+
+    return $inv->_inline_throw_error($msg, $args)
 }
 
 1;

diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm
index a412b53..9c9b858 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor.pm
@@ -73,7 +73,10 @@ sub _eval_environment {
     # XXX ugh, fix these
     $env->{'$attr'} = \$attr
         if $attr->has_initializer && $attr->is_lazy;
-    $env->{'$meta'} = \$self;
+    # 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
+    $env->{'$meta'} = \($self->associated_metaclass);
 
     return $env;
 }

diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index ca47dca..cd41e58 100644 (file)
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -86,7 +86,6 @@ sub _eval_environment {
     } @type_constraints;
 
     return {
-        '$meta'  => \$self,
         ((any { defined && $_->has_initializer } @$attrs)
             ? ('$attrs' => \$attrs)
             : ()),
@@ -97,6 +96,10 @@ sub _eval_environment {
         '@type_constraint_bodies' => \@type_constraint_bodies,
         ( 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),
     };
 }
 

diff --git a/t/metaclasses/throw_error.t b/t/metaclasses/throw_error.t
index a332c93..246754d 100644 (file)
--- a/t/metaclasses/throw_error.t
+++ b/t/metaclasses/throw_error.t
@@ -5,6 +5,7 @@ use warnings;
 
 use Test::More;
 use Test::Fatal;
+use Test::Moose;
 
 {
 
@@ -63,6 +64,7 @@ sub create_error {
     };
 }
 
+with_immutable {
 {
     my $e = create_error( Foo->new );
     ok( !ref( $e->{error} ), "error is a string" );
@@ -91,6 +93,7 @@ sub create_error {
     is_deeply( $e->{error}->data, [ $baz, 4 ], "captured args" );
     like( $e->{error}->last_error, qr/Blah/, "last error preserved" );
 }
+} 'Foo', 'Bar', 'Baz';
 
 {
     package Role::Foo;
@@ -200,6 +203,7 @@ sub stacktrace_not_ok (&) {
     cmp_ok(scalar(@lines), '==', 1, "didn't get a stacktrace");
 }
 
+with_immutable {
 my $default = Quux::Default->new;
 my $croak = Quux::Croak->new;
 my $confess = Quux::Confess->new;
@@ -228,5 +232,6 @@ is($confess->meta->error_class, 'Moose::Error::Confess');
     stacktrace_not_ok { $croak->bar };
     stacktrace_ok { $confess->bar };
 }
+} 'Quux::Default', 'Quux::Croak', 'Quux::Confess';
 
 done_testing;