From: Yuval Kogman Date: Thu, 26 Jun 2008 07:49:59 +0000 (+0000) Subject: Method::Accessor throw_error code X-Git-Tag: 0.58~54^2~7 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cee532a1b41946fa5e5a0ac75547df73959869e9;p=gitmo%2FMoose.git Method::Accessor throw_error code --- diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 480768b..7448b81 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -534,7 +534,7 @@ sub install_accessors { my $name = "${class_name}::${handle}"; (!$associated_class->has_method($handle)) - || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method => $handle); + || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle); # NOTE: # handles is not allowed to delegate @@ -565,7 +565,7 @@ sub install_accessors { my $proxy = $instance->$accessor(); (defined $proxy) || $self->throw_error("Cannot delegate $handle to $method_to_call because " . - "the value of " . $self->name . " is not defined", method => $method_to_call, object => $instance); + "the value of " . $self->name . " is not defined", method_name => $method_to_call, object => $instance); $proxy->$method_to_call(@_); })); } diff --git a/lib/Moose/Meta/Method.pm b/lib/Moose/Meta/Method.pm index fe12886..9551bea 100644 --- a/lib/Moose/Meta/Method.pm +++ b/lib/Moose/Meta/Method.pm @@ -8,6 +8,20 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Method'; +sub throw_error { + my $self = shift; + my $inv = ( ref $self && ( $self->associated_attribute || $self->associated_class ) ) || "Moose::Meta::Class"; + unshift @_, "message" if @_ % 2 == 1; + unshift @_, method => $self if ref $self; + unshift @_, $inv; + goto $inv->can("throw_error"); # to avoid incrementing depth by 1 +} + +sub _inline_throw_error { + my ( $self, $msg, $args ) = @_; + "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard +} + 1; __END__ @@ -24,6 +38,16 @@ For now, this is nothing but a subclass of Class::MOP::Method, but with the expanding role of the method sub-protocol, it might be more useful later on. +=head1 METHODS + +=over 4 + +=item throw_error $msg, %args + +=item _inline_throw_error $msg_expr, $args_expr + +=back + =head1 BUGS All complex software has bugs lurking in it, and this module is no @@ -43,4 +67,4 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm index 8460b6a..c8cd7c2 100644 --- a/lib/Moose/Meta/Method/Accessor.pm +++ b/lib/Moose/Meta/Method/Accessor.pm @@ -4,8 +4,6 @@ package Moose::Meta::Method::Accessor; use strict; use warnings; -use Carp 'confess'; - our $VERSION = '0.50'; our $AUTHORITY = 'cpan:STEVAN'; @@ -21,6 +19,7 @@ sub _eval_code { # set up the environment my $attr = $self->associated_attribute; my $attr_name = $attr->name; + my $meta = $self, my $type_constraint_obj = $attr->type_constraint; my $type_constraint_name = $type_constraint_obj && $type_constraint_obj->name; @@ -30,7 +29,7 @@ sub _eval_code { #warn "code for $attr_name =>\n" . $code . "\n"; my $sub = eval $code; - confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@; + $self->throw_error("Could not create writer for '$attr_name' because $@ \n code: $code", error => $@, data => $code ) if $@; return $sub; } @@ -88,7 +87,7 @@ sub generate_reader_method_inline { $self->_eval_code('sub {' . $self->_inline_pre_body(@_) - . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;' + . $self->_inline_throw_error('"Cannot assign a value to a read-only accessor"', 'data => \@_') . ' if @_ > 1;' . $self->_inline_check_lazy . $self->_inline_post_body(@_) . 'return ' . $self->_inline_auto_deref( $slot_access ) . ';' @@ -122,14 +121,7 @@ sub _inline_check_constraint { my $type_constraint_name = $attr->type_constraint->name; - # FIXME - # This sprintf is insanely annoying, we should - # fix it someday - SL - return sprintf <<'EOF', $value, $attr_name, $value, $value, -$type_constraint->(%s) - || confess "Attribute (%s) does not pass the type constraint because: " - . $type_constraint_obj->get_message(%s); -EOF + qq{\$type_constraint->($value) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) does not pass the type constraint because: " . \$type_constraint_obj->get_message($value)}, "data => $value") . ";"; } sub _inline_check_coercion { @@ -140,12 +132,13 @@ sub _inline_check_coercion { } sub _inline_check_required { - my $attr = (shift)->associated_attribute; + my $self = shift; + my $attr = $self->associated_attribute; my $attr_name = $attr->name; return '' unless $attr->is_required; - return qq{(\@_ >= 2) || confess "Attribute ($attr_name) is required, so cannot be set to undef";} # defined $_[1] is not good enough + return qq{(\@_ >= 2) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) is required, so cannot be set to undef"}) . ';' # defined $_[1] is not good enough } sub _inline_check_lazy { @@ -169,13 +162,13 @@ sub _inline_check_lazy { $code .= ' my $default;'."\n". ' if(my $builder = '.$inv.'->can($attr->builder)){ '."\n". ' $default = '.$inv.'->$builder; '. "\n } else {\n" . - ' confess(Scalar::Util::blessed('.$inv.')." does not support builder method '. - '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'");'. "\n }"; + ' ' . $self->_inline_throw_error('Scalar::Util::blessed('.$inv.')." does not support builder method '. + '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'"') . ';'. "\n }"; } $code .= ' $default = $type_constraint_obj->coerce($default);'."\n" if $attr->should_coerce; $code .= ' ($type_constraint->($default))' . - ' || confess "Attribute (" . $attr_name . ") does not pass the type constraint ("' . - ' . $type_constraint_name . ") with " . (defined($default) ? overload::StrVal($default) : "undef");' + ' || ' . $self->_inline_throw_error('"Attribute (" . $attr_name . ") does not pass the type constraint ("' . + ' . $type_constraint_name . ") with " . (defined($default) ? overload::StrVal($default) : "undef")' ) . ';' . "\n"; $code .= ' ' . $self->_inline_init_slot($attr, $inv, $slot_access, '$default') . "\n"; } @@ -191,8 +184,8 @@ sub _inline_check_lazy { $code .= ' if (my $builder = '.$inv.'->can($attr->builder)) { ' . "\n" . ' ' . $self->_inline_init_slot($attr, $inv, $slot_access, ($inv . '->$builder')) . "\n } else {\n" . - ' confess(Scalar::Util::blessed('.$inv.')." does not support builder method '. - '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'");'. "\n }"; + ' ' . $self->_inline_throw_error('Scalar::Util::blessed('.$inv.')." does not support builder method '. + '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'"') . ';'. "\n }"; } else { $code .= ' ' . $self->_inline_init_slot($attr, $inv, $slot_access, 'undef') . "\n"; @@ -278,7 +271,7 @@ sub _inline_auto_deref { $sigil = '%'; } else { - confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'"; + $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", data => $type_constraint ); } "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )"; diff --git a/lib/Moose/Meta/Method/Overriden.pm b/lib/Moose/Meta/Method/Overriden.pm index 25b18b2..9b661d6 100644 --- a/lib/Moose/Meta/Method/Overriden.pm +++ b/lib/Moose/Meta/Method/Overriden.pm @@ -3,8 +3,6 @@ package Moose::Meta::Method::Overriden; use strict; use warnings; -use Carp 'confess'; - our $VERSION = '0.50'; our $AUTHORITY = 'cpan:STEVAN'; @@ -24,7 +22,7 @@ sub new { my $super = $args{class}->find_next_method_by_name($name); (defined $super) - || confess "You cannot override '$name' because it has no super method"; + || $class->throw_error("You cannot override '$name' because it has no super method", data => $name); my $super_body = $super->body;