From: Jesse Luehrs Date: Mon, 25 Apr 2011 17:13:51 +0000 (-0500) Subject: stop closing over the method metaobject X-Git-Tag: 2.0100~28 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bcc04ae144478d804246a90cbccc5f2b857935b3;p=gitmo%2FMoose.git 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 --- 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 diff --git a/lib/Moose/Error/Croak.pm b/lib/Moose/Error/Croak.pm index 0c8b04c..9917b96 100644 --- 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 diff --git a/lib/Moose/Error/Default.pm b/lib/Moose/Error/Default.pm index 47c0024..d3673f0 100644 --- 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 based error generation for Moose. diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index e6d5172..20d8a79 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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;