X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FMethod%2FConstructor.pm;h=b7b38f5e112f29f3c95e438bfde7edebec6f94e0;hb=a05f85c1308adbbb4b60b1db95103ee2e279e1ea;hp=1012d08f7b48ee7b9654e507ccff6f24139fe5be;hpb=7bec196c5513eab13177370e65889ac9af4489de;p=gitmo%2FMoose.git

diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index 1012d08..b7b38f5 100644
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -4,10 +4,9 @@ package Moose::Meta::Method::Constructor;
 use strict;
 use warnings;
 
-use Carp         'confess';
 use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
 
-our $VERSION   = '0.50';
+our $VERSION   = '0.57';
 our $AUTHORITY = 'cpan:STEVAN';
 
 use base 'Moose::Meta::Method',
@@ -17,29 +16,31 @@ sub new {
     my $class   = shift;
     my %options = @_;
 
-    (exists $options{options} && ref $options{options} eq 'HASH')
-        || confess "You must pass a hash of options";
+    my $meta = $options{metaclass};
+
+    (ref $options{options} eq 'HASH')
+        || $class->throw_error("You must pass a hash of options", data => $options{options});
 
     ($options{package_name} && $options{name})
-        || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
+        || $class->throw_error("You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT");
 
     my $self = bless {
         # from our superclass
-        '&!body'          => undef, 
-        '$!package_name'  => $options{package_name},
-        '$!name'          => $options{name},
+        'body'          => undef, 
+        'package_name'  => $options{package_name},
+        'name'          => $options{name},
         # specific to this subclass
-        '%!options'       => $options{options},
-        '$!meta_instance' => $options{metaclass}->get_meta_instance,
-        '@!attributes'    => [ $options{metaclass}->compute_all_applicable_attributes ],
+        'options'       => $options{options},
+        'meta_instance' => $meta->get_meta_instance,
+        'attributes'    => [ $meta->compute_all_applicable_attributes ],
         # ...
-        '$!associated_metaclass' => $options{metaclass},
+        'associated_metaclass' => $meta,
     } => $class;
 
     # we don't want this creating
     # a cycle in the code, if not
     # needed
-    weaken($self->{'$!associated_metaclass'});
+    weaken($self->{'associated_metaclass'});
 
     $self->initialize_body;
 
@@ -48,17 +49,17 @@ sub new {
 
 ## accessors
 
-sub options       { (shift)->{'%!options'}       }
-sub meta_instance { (shift)->{'$!meta_instance'} }
-sub attributes    { (shift)->{'@!attributes'}    }
+sub options       { (shift)->{'options'}       }
+sub meta_instance { (shift)->{'meta_instance'} }
+sub attributes    { (shift)->{'attributes'}    }
 
-sub associated_metaclass { (shift)->{'$!associated_metaclass'} }
+sub associated_metaclass { (shift)->{'associated_metaclass'} }
 
 ## method
 
 # this was changed in 0.41, but broke MooseX::Singleton, so try to catch
 # any other code using the original broken spelling
-sub intialize_body { confess "Please correct the spelling of 'intialize_body' to 'initialize_body'" }
+sub intialize_body { Moose->throw_error("Please correct the spelling of 'intialize_body' to 'initialize_body'") }
 
 sub initialize_body {
     my $self = shift;
@@ -92,6 +93,8 @@ sub initialize_body {
 
     my $code;
     {
+        my $meta = $self; # FIXME for _inline_throw_error...
+
         # NOTE:
         # create the nessecary lexicals
         # to be picked up in the eval
@@ -115,9 +118,9 @@ sub initialize_body {
         } @type_constraints;
 
         $code = eval $source;
-        confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
+        $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source ) if $@;
     }
-    $self->{'&!body'} = $code;
+    $self->{'body'} = $code;
 }
 
 sub _generate_BUILDARGS {
@@ -125,10 +128,10 @@ sub _generate_BUILDARGS {
 
     my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
 
-    if ( !$buildargs || $buildargs->body == \&Moose::Object::BUILDARGS and $args eq '@_') {
+    if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
         return join("\n",
             'do {',
-            'confess "Single parameters to new() must be a HASH ref"',
+            $self->_inline_throw_error('"Single parameters to new() must be a HASH ref"', 'data => $_[0]'),
             '    if scalar @_ == 1 && defined $_[0] && ref($_[0]) ne q{HASH};',
             '(scalar @_ == 1) ? {%{$_[0]}} : {@_};',
             '}',
@@ -185,34 +188,17 @@ sub _generate_slot_initializer {
 
     if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
         push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
-                        '|| confess "Attribute (' . $attr->name . ') is required";');
+                        '|| ' . $self->_inline_throw_error('"Attribute (' . $attr->name . ') is required"') .';');
     }
 
     if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
 
         if ( defined( my $init_arg = $attr->init_arg ) ) {
             push @source => 'if (exists $params->{\'' . $init_arg . '\'}) {';
-
-                push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
-
-                if ($is_moose && $attr->has_type_constraint) {
-                    if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
-                        push @source => $self->_generate_type_coercion(
-                            $attr, 
-                            '$type_constraints[' . $index . ']', 
-                            '$val', 
-                            '$val'
-                        );
-                    }
-                    push @source => $self->_generate_type_constraint_check(
-                        $attr, 
-                        '$type_constraint_bodies[' . $index . ']', 
-                        '$type_constraints[' . $index . ']',                         
-                        '$val'
-                    );
-                }
-                push @source => $self->_generate_slot_assignment($attr, '$val', $index);
-
+            push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
+            push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
+                if $is_moose;
+            push @source => $self->_generate_slot_assignment($attr, '$val', $index);
             push @source => "} else {";
         }
             my $default;
@@ -226,13 +212,8 @@ sub _generate_slot_initializer {
             
             push @source => '{'; # wrap this to avoid my $val overwrite warnings
             push @source => ('my $val = ' . $default . ';');
-            push @source => $self->_generate_type_constraint_check(
-                $attr,
-                ('$type_constraint_bodies[' . $index . ']'),
-                ('$type_constraints[' . $index . ']'),                
-                '$val'
-            ) if ($is_moose && $attr->has_type_constraint);
-            
+            push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
+                if $is_moose; 
             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
             push @source => '}'; # close - wrap this to avoid my $val overrite warnings           
 
@@ -302,6 +283,29 @@ sub _generate_slot_assignment {
     return $source;
 }
 
+sub _generate_type_constraint_and_coercion {
+    my ($self, $attr, $index) = @_;
+    
+    return unless $attr->has_type_constraint;
+    
+    my @source;
+    if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
+        push @source => $self->_generate_type_coercion(
+            $attr,
+            '$type_constraints[' . $index . ']',
+            '$val',
+            '$val'
+        );
+    }
+    push @source => $self->_generate_type_constraint_check(
+        $attr,
+        ('$type_constraint_bodies[' . $index . ']'),
+        ('$type_constraints[' . $index . ']'),            
+        '$val'
+    );
+    return @source;
+}
+
 sub _generate_type_coercion {
     my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
     return ($return_value_name . ' = ' . $type_constraint_name .  '->coerce(' . $value_name . ');');
@@ -310,11 +314,11 @@ sub _generate_type_coercion {
 sub _generate_type_constraint_check {
     my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
     return (
-        $type_constraint_cv . '->(' . $value_name . ')'
-        . "\n\t" . '|| confess "Attribute (' 
+        $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
         . $attr->name 
         . ') does not pass the type constraint because: " . ' 
-        . $type_constraint_obj . '->get_message(' . $value_name . ');'
+        . $type_constraint_obj . '->get_message(' . $value_name . ')')
+        . "\n\t unless " .  $type_constraint_cv . '->(' . $value_name . ');'
     );
 }