From: Yuval Kogman <nothingmuch@woobling.org>
Date: Mon, 23 Jun 2008 15:01:25 +0000 (+0000)
Subject: throw_error in Attribute
X-Git-Tag: 0.58~54^2~10
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=be05faea2de65e890bb91af2f2341f644e95883e;p=gitmo%2FMoose.git

throw_error in Attribute
---

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 787c85c..d1fe25b 100644
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -59,6 +59,15 @@ __PACKAGE__->meta->add_attribute('traits' => (
 # - SL
 *does = \&Moose::Object::does;
 
+sub throw_error {
+    my $self = shift;
+    my $class = ( ref $self && $self->associated_class ) || "Moose::Meta::Class";
+    unshift @_, "message" if @_ % 2 == 1;
+    unshift @_, attr => $self if ref $self;
+    unshift @_, $class;
+    goto $class->can("throw_error"); # to avoid incrementing depth by 1
+}
+
 sub new {
     my ($class, $name, %options) = @_;
     $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
@@ -131,7 +140,7 @@ sub clone_and_inherit_options {
         else {
             $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
             (defined $type_constraint)
-                || confess "Could not find the type constraint '" . $options{isa} . "'";
+                || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
         }
 
         $actual_options{type_constraint} = $type_constraint;
@@ -146,7 +155,7 @@ sub clone_and_inherit_options {
         else {
             $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
             (defined $type_constraint)
-                || confess "Could not find the type constraint '" . $options{does} . "'";
+                || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
         }
 
         $actual_options{type_constraint} = $type_constraint;
@@ -168,7 +177,7 @@ sub clone_and_inherit_options {
     }
 
     (scalar keys %options == 0)
-        || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
+        || $self->throw_error("Illegal inherited options => (" . (join ', ' => keys %options) . ")", data => \%options);
 
 
     $self->clone(%actual_options);
@@ -218,7 +227,7 @@ is => ro, accessor => _foo  # error, accesor is rw
 =cut        
         
         if ($options->{is} eq 'ro') {
-            confess "Cannot define an accessor name on a read-only attribute, accessors are read/write"
+            $class->throw_error("Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options)
                 if exists $options->{accessor};
             $options->{reader} ||= $name;
         }
@@ -231,7 +240,7 @@ is => ro, accessor => _foo  # error, accesor is rw
             }
         }
         else {
-            confess "I do not understand this option (is => " . $options->{is} . ") on attribute $name"
+            $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute $name", data => $options->{is});
         }
     }
 
@@ -239,10 +248,10 @@ is => ro, accessor => _foo  # error, accesor is rw
         if (exists $options->{does}) {
             if (eval { $options->{isa}->can('does') }) {
                 ($options->{isa}->does($options->{does}))
-                    || confess "Cannot have an isa option and a does option if the isa does not do the does on attribute $name";
+                    || $class->throw_error("Cannot have an isa option and a does option if the isa does not do the does on attribute $name", data => $options);
             }
             else {
-                confess "Cannot have an isa option which cannot ->does() on attribute $name";
+                $class->throw_error("Cannot have an isa option which cannot ->does() on attribute $name", data => $options);
             }
         }
 
@@ -266,26 +275,26 @@ is => ro, accessor => _foo  # error, accesor is rw
 
     if (exists $options->{coerce} && $options->{coerce}) {
         (exists $options->{type_constraint})
-            || confess "You cannot have coercion without specifying a type constraint on attribute $name";
-        confess "You cannot have a weak reference to a coerced value on attribute $name"
+            || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute $name", data => $options);
+        $class->throw_error("You cannot have a weak reference to a coerced value on attribute $name", data => $options)
             if $options->{weak_ref};
     }
 
     if (exists $options->{trigger}) {
         ('CODE' eq ref $options->{trigger})
-            || confess "Trigger must be a CODE ref";
+            || $class->throw_error("Trigger must be a CODE ref", data => $options->{trigger});
     }
 
     if (exists $options->{auto_deref} && $options->{auto_deref}) {
         (exists $options->{type_constraint})
-            || confess "You cannot auto-dereference without specifying a type constraint on attribute $name";
+            || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute $name", data => $options);
         ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
          $options->{type_constraint}->is_a_type_of('HashRef'))
-            || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute $name";
+            || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute $name", data => $options);
     }
 
     if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
-        confess("You can not use lazy_build and default for the same attribute $name")
+        $class->throw_error("You can not use lazy_build and default for the same attribute $name", data => $options)
             if exists $options->{default};
         $options->{lazy}      = 1;
         $options->{required}  = 1;
@@ -302,11 +311,11 @@ is => ro, accessor => _foo  # error, accesor is rw
 
     if (exists $options->{lazy} && $options->{lazy}) {
         (exists $options->{default} || defined $options->{builder} )
-            || confess "You cannot have lazy attribute ($name) without specifying a default value for it";
+            || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it", data => $options);
     }
 
     if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) {
-        confess "You cannot have a required attribute ($name) without a default, builder, or an init_arg";
+        $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options);
     }
 
 }
@@ -326,7 +335,7 @@ sub initialize_instance_slot {
         # skip it if it's lazy
         return if $self->is_lazy;
         # and die if it's required and doesn't have a default value
-        confess "Attribute (" . $self->name . ") is required"
+        $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
             if $self->is_required && !$self->has_default && !$self->has_builder;
 
         # if nothing was in the %params, we can use the
@@ -341,7 +350,7 @@ sub initialize_instance_slot {
                 $value_is_set = 1;
             } 
             else {
-                confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'");
+                $self->throw_error(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'", object => $instance, data => $params);
             }
         }
     }
@@ -354,10 +363,10 @@ sub initialize_instance_slot {
             $val = $type_constraint->coerce($val);
         }
         $type_constraint->check($val)
-            || confess "Attribute (" 
+            || $self->throw_error("Attribute (" 
                      . $self->name 
                      . ") does not pass the type constraint because: " 
-                     . $type_constraint->get_message($val);
+                     . $type_constraint->get_message($val), data => $val, object => $instance);
     }
 
     $self->set_initial_value($instance, $val);
@@ -392,10 +401,10 @@ sub _set_initial_slot_value {
             $val = $type_constraint->coerce($val)
                 if $can_coerce;
             $type_constraint->check($val)
-                || confess "Attribute (" 
+                || $self->throw_error("Attribute (" 
                          . $slot_name 
                          . ") does not pass the type constraint because: " 
-                         . $type_constraint->get_message($val);            
+                         . $type_constraint->get_message($val), data => $val, object => $instance);
         }
         $meta_instance->set_slot_value($instance, $slot_name, $val);
     };
@@ -413,7 +422,7 @@ sub set_value {
     my $attr_name = $self->name;
 
     if ($self->is_required and not @args) {
-        confess "Attribute ($attr_name) is required";
+        $self->throw_error("Attribute ($attr_name) is required", object => $instance);
     }
 
     if ($self->has_type_constraint) {
@@ -424,10 +433,10 @@ sub set_value {
             $value = $type_constraint->coerce($value);
         }        
         $type_constraint->_compiled_type_constraint->($value)
-            || confess "Attribute (" 
+            || $self->throw_error("Attribute (" 
                      . $self->name 
                      . ") does not pass the type constraint because " 
-                     . $type_constraint->get_message($value);
+                     . $type_constraint->get_message($value), object => $instance, data => $value);
     }
 
     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
@@ -457,12 +466,12 @@ sub get_value {
                     $self->set_initial_value($instance, $instance->$builder);
                 }
                 else {
-                    confess(blessed($instance) 
+                    $self->throw_error(blessed($instance) 
                           . " does not support builder method '"
                           . $self->builder 
                           . "' for attribute '" 
                           . $self->name 
-                          . "'");
+                          . "'", object => $instance);
                 }
             } 
             else {
@@ -486,7 +495,7 @@ sub get_value {
             return wantarray ? %{ $rv } : $rv;
         }
         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 . "'", object => $instance, data => $type_constraint);
         }
 
     }
@@ -526,7 +535,7 @@ sub install_accessors {
             my $name = "${class_name}::${handle}";
 
             (!$associated_class->has_method($handle))
-                || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
+                || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method => $handle);
 
             # NOTE:
             # handles is not allowed to delegate
@@ -553,10 +562,11 @@ sub install_accessors {
                 # in the stack trace. 
                 # - SL
                 $associated_class->add_method($handle => Class::MOP::subname($name, sub {
-                    my $proxy = (shift)->$accessor();
+                    my $instance = shift;
+                    my $proxy = $instance->$accessor();
                     (defined $proxy) 
-                        || confess "Cannot delegate $handle to $method_to_call because " . 
-                                   "the value of " . $self->name . " is not defined";
+                        || $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);
                     $proxy->$method_to_call(@_);
                 }));
             }
@@ -580,7 +590,7 @@ sub _canonicalize_handles {
         }
         elsif ($handle_type eq 'Regexp') {
             ($self->has_type_constraint)
-                || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
+                || $self->throw_error("Cannot delegate methods based on a RegExpr without a type constraint (isa)", data => $handles);
             return map  { ($_ => $_) }
                    grep { /$handles/ } $self->_get_delegate_method_list;
         }
@@ -588,17 +598,17 @@ sub _canonicalize_handles {
             return $handles->($self, $self->_find_delegate_metaclass);
         }
         else {
-            confess "Unable to canonicalize the 'handles' option with $handles";
+            $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
         }
     }
     else {
         my $role_meta = eval { $handles->meta };
         if ($@) {
-            confess "Unable to canonicalize the 'handles' option with $handles because : $@";
+            $self->throw_error("Unable to canonicalize the 'handles' option with $handles because : $@", data => $handles, error => $@);
         }
 
         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
-            || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
+            || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role", data => $handles);
 
         return map { $_ => $_ } (
             $role_meta->get_method_list,
@@ -625,7 +635,7 @@ sub _find_delegate_metaclass {
         return $role->meta;
     }
     else {
-        confess "Cannot find delegate metaclass for attribute " . $self->name;
+        $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
     }
 }
 
@@ -641,7 +651,7 @@ sub _get_delegate_method_list {
         return $meta->get_method_list;
     }
     else {
-        confess "Unable to recognize the delegate metaclass '$meta'";
+        $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
     }
 }
 
@@ -722,6 +732,10 @@ creation and type coercion.
 
 =over 4
 
+=item B<throw_error>
+
+Delegates to C<associated_class> or C<Moose::Meta::Class> if there is none.
+
 =item B<interpolate_class_and_new>
 
 =item B<interpolate_class>
diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index c4f057d..b5fb740 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -455,7 +455,7 @@ sub create_error {
         unshift @args, "message";
     }
 
-    my %args = @args;
+    my %args = ( meta => $self, error => $@, @args );
 
     local $level = $level + 1;
 
@@ -478,7 +478,6 @@ sub create_error_object {
     my $class = delete $args{class};
 
     $class->new(
-        metaclass => $self,
         %args,
         depth => ( ($args{depth} || 1) + ( $level + 1 ) ),
     );
diff --git a/lib/Moose/Object.pm b/lib/Moose/Object.pm
index f3dce58..f0b8463 100644
--- a/lib/Moose/Object.pm
+++ b/lib/Moose/Object.pm
@@ -15,17 +15,18 @@ our $AUTHORITY = 'cpan:STEVAN';
 sub new {
     my $class = shift;
     my %params;
+    my $meta = $class->meta;
     if (scalar @_ == 1) {
         if (defined $_[0]) {
             (ref($_[0]) eq 'HASH')
-                || confess "Single parameters to new() must be a HASH ref";
+                || $meta->throw_error("Single parameters to new() must be a HASH ref", data => $_[0]);
             %params = %{$_[0]};
         }
     }
     else {
         %params = @_;
     }
-    my $self = $class->meta->new_object(%params);
+    my $self = $meta->new_object(%params);
     $self->BUILDALL(\%params);
     return $self;
 }
@@ -70,9 +71,9 @@ sub DESTROY {
 # as approiate see Moose::Meta::Role
 sub does {
     my ($self, $role_name) = @_;
-    (defined $role_name)
-        || confess "You much supply a role name to does()";
     my $meta = $self->meta;
+    (defined $role_name)
+        || $meta->throw_error("You much supply a role name to does()");
     foreach my $class ($meta->class_precedence_list) {
         my $m = $meta->initialize($class);
         return 1