stop closing over the type constraint object

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 20d8a79..aec1ef1 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -572,13 +572,13 @@ sub set_value {
 
 sub _inline_set_value {
     my $self = shift;
-    my ($instance, $value, $tc, $coercion, $tc_obj, $for_constructor) = @_;
+    my ($instance, $value, $tc, $coercion, $message, $for_constructor) = @_;
 
     my $old     = '@old';
     my $copy    = '$val';
     $tc       ||= '$type_constraint';
     $coercion ||= '$type_coercion';
-    $tc_obj   ||= '$type_constraint_obj';
+    $message  ||= '$type_message';
 
     my @code;
     if ($self->_writer_value_needs_copy) {
@@ -590,7 +590,7 @@ sub _inline_set_value {
     push @code, $self->_inline_check_required
         unless $for_constructor;
 
-    push @code, $self->_inline_tc_code($value, $tc, $coercion, $tc_obj);
+    push @code, $self->_inline_tc_code($value, $tc, $coercion, $message);
 
     # constructors do triggers all at once at the end
     push @code, $self->_inline_get_old_value_for_trigger($instance, $old)
@@ -639,13 +639,13 @@ sub _inline_check_required {
 
 sub _inline_tc_code {
     my $self = shift;
-    my ($value, $tc, $coercion, $tc_obj, $is_lazy) = @_;
+    my ($value, $tc, $coercion, $message, $is_lazy) = @_;
     return (
         $self->_inline_check_coercion(
             $value, $tc, $coercion, $is_lazy,
         ),
         $self->_inline_check_constraint(
-            $value, $tc, $tc_obj, $is_lazy,
+            $value, $tc, $message, $is_lazy,
         ),
     );
 }
@@ -674,7 +674,7 @@ sub _inline_check_coercion {
 
 sub _inline_check_constraint {
     my $self = shift;
-    my ($value, $tc, $tc_obj) = @_;
+    my ($value, $tc, $message) = @_;
 
     return unless $self->has_type_constraint;
 
@@ -686,7 +686,9 @@ sub _inline_check_constraint {
                 $self->_inline_throw_error(
                     '"Attribute (' . $attr_name . ') does not pass the type '
                   . 'constraint because: " . '
-                  . $tc_obj . '->get_message(' . $value . ')',
+                  . 'do { local $_ = ' . $value . '; '
+                      . $message . '->(' . $value . ')'
+                  . '}',
                     'data => ' . $value
                 ) . ';',
             '}',
@@ -698,7 +700,9 @@ sub _inline_check_constraint {
                 $self->_inline_throw_error(
                     '"Attribute (' . $attr_name . ') does not pass the type '
                   . 'constraint because: " . '
-                  . $tc_obj . '->get_message(' . $value . ')',
+                  . 'do { local $_ = ' . $value . '; '
+                      . $message . '->(' . $value . ')'
+                  . '}',
                     'data => ' . $value
                 ) . ';',
             '}',
@@ -795,22 +799,22 @@ sub get_value {
 
 sub _inline_get_value {
     my $self = shift;
-    my ($instance, $tc, $coercion, $tc_obj) = @_;
+    my ($instance, $tc, $coercion, $message) = @_;
 
     my $slot_access = $self->_inline_instance_get($instance);
     $tc           ||= '$type_constraint';
     $coercion     ||= '$type_coercion';
-    $tc_obj       ||= '$type_constraint_obj';
+    $message      ||= '$type_message';
 
     return (
-        $self->_inline_check_lazy($instance, $tc, $coercion, $tc_obj),
+        $self->_inline_check_lazy($instance, $tc, $coercion, $message),
         $self->_inline_return_auto_deref($slot_access),
     );
 }
 
 sub _inline_check_lazy {
     my $self = shift;
-    my ($instance, $tc, $coercion, $tc_obj) = @_;
+    my ($instance, $tc, $coercion, $message) = @_;
 
     return unless $self->is_lazy;
 
@@ -818,14 +822,14 @@ sub _inline_check_lazy {
 
     return (
         'if (!' . $slot_exists . ') {',
-            $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $tc_obj, 'lazy'),
+            $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $message, 'lazy'),
         '}',
     );
 }
 
 sub _inline_init_from_default {
     my $self = shift;
-    my ($instance, $default, $tc, $coercion, $tc_obj, $for_lazy) = @_;
+    my ($instance, $default, $tc, $coercion, $message, $for_lazy) = @_;
 
     if (!($self->has_default || $self->has_builder)) {
         $self->throw_error(
@@ -843,7 +847,7 @@ sub _inline_init_from_default {
         # appropriate for checking the result of a default
         $self->has_type_constraint
             ? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy),
-               $self->_inline_check_constraint($default, $tc, $tc_obj, $for_lazy))
+               $self->_inline_check_constraint($default, $tc, $message, $for_lazy))
             : (),
         $self->_inline_init_slot($instance, $default),
     );

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 821902e..7d8e55d 100644 (file)
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -382,7 +382,7 @@ sub _inline_init_attr_from_constructor {
         '$params->{\'' . $attr->init_arg . '\'}',
         '$type_constraint_bodies[' . $idx . ']',
         '$type_coercions[' . $idx . ']',
-        '$type_constraints[' . $idx . ']',
+        '$type_constraint_messages[' . $idx . ']',
         'for constructor',
     );
 
@@ -411,7 +411,7 @@ sub _inline_init_attr_from_default {
             '$default',
             '$type_constraint_bodies[' . $idx . ']',
             '$type_coercions[' . $idx . ']',
-            '$type_constraints[' . $idx . ']',
+            '$type_constraint_messages[' . $idx . ']',
             'for constructor',
         ),
     );

diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm
index 9c9b858..93148d0 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor.pm
@@ -56,16 +56,16 @@ sub _eval_environment {
     if ($attr->has_type_constraint) {
         my $tc_obj = $attr->type_constraint;
 
-        # is this going to be an issue? it's currently only used for the tc
-        # message. is there a way to inline that too?
-        $env->{'$type_constraint_obj'} = \$tc_obj;
-
         $env->{'$type_constraint'} = \(
             $tc_obj->_compiled_type_constraint
         ) unless $tc_obj->can_be_inlined;
+        # these two could probably get inlined versions too
         $env->{'$type_coercion'} = \(
             $tc_obj->coercion->_compiled_type_coercion
         ) if $tc_obj->has_coercion;
+        $env->{'$type_message'} = \(
+            $tc_obj->has_message ? $tc_obj->message : $tc_obj->_default_message
+        );
 
         $env = { %$env, %{ $tc_obj->inline_environment } };
     }

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm
index 941e00c..75eba86 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm
@@ -35,7 +35,7 @@ sub _generate_method {
         'sub {',
             'my ' . $inv . ' = shift;',
             $self->_inline_curried_arguments,
-            $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'),
+            $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'),
             # get
             'if (@_ == 1) {',
                 $self->_inline_check_var_is_valid_index('$_[0]'),

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
index 8d63951..4754768 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
@@ -50,7 +50,7 @@ sub _writer_value_needs_copy {
 
 sub _inline_tc_code {
     my $self = shift;
-    my ($value, $tc, $coercion, $tc_obj, $is_lazy) = @_;
+    my ($value, $tc, $coercion, $message, $is_lazy) = @_;
 
     return unless $self->_constraint_must_be_checked;
 
@@ -62,7 +62,7 @@ sub _inline_tc_code {
     else {
         return (
             $self->_inline_check_coercion($value, $tc, $coercion, $is_lazy),
-            $self->_inline_check_constraint($value, $tc, $tc_obj, $is_lazy),
+            $self->_inline_check_constraint($value, $tc, $message, $is_lazy),
         );
     }
 }

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm
index 3a5de7f..af68689 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm
@@ -38,7 +38,7 @@ sub _generate_method {
         'sub {',
             'my ' . $inv . ' = shift;',
             $self->_inline_curried_arguments,
-            $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'),
+            $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'),
             # get
             'if (@_ == 1) {',
                 $self->_inline_check_var_is_valid_key('$_[0]'),

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm
index 9d08fb8..2a0744f 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm
@@ -32,7 +32,7 @@ sub _inline_reader_core {
         $self->_inline_check_argument_count,
         $self->_inline_process_arguments($inv, $slot_access),
         $self->_inline_check_arguments,
-        $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'),
+        $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'),
         $self->_inline_return_value($slot_access),
     );
 }

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
index 1ea3ced..06f3042 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
@@ -38,7 +38,7 @@ sub _inline_writer_core {
         $self->_inline_check_argument_count,
         $self->_inline_process_arguments($inv, $slot_access),
         $self->_inline_check_arguments('for writer'),
-        $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'),
+        $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'),
     );
 
     if ($self->_return_value($slot_access)) {
@@ -50,7 +50,7 @@ sub _inline_writer_core {
     push @code, (
         $self->_inline_coerce_new_values,
         $self->_inline_copy_native_value(\$potential),
-        $self->_inline_tc_code($potential, '$type_constraint', '$type_coercion', '$type_constraint_obj'),
+        $self->_inline_tc_code($potential, '$type_constraint', '$type_coercion', '$type_message'),
         $self->_inline_get_old_value_for_trigger($inv, $old),
         $self->_inline_capture_return_value($slot_access),
         $self->_inline_set_new_value($inv, $potential, $slot_access),
@@ -109,7 +109,7 @@ sub _inline_copy_native_value {
 around _inline_tc_code => sub {
     my $orig = shift;
     my $self = shift;
-    my ($value, $tc, $coercion, $tc_obj, $for_lazy) = @_;
+    my ($value, $tc, $coercion, $message, $for_lazy) = @_;
 
     return unless $for_lazy || $self->_constraint_must_be_checked;
 
@@ -119,7 +119,7 @@ around _inline_tc_code => sub {
 around _inline_check_constraint => sub {
     my $orig = shift;
     my $self = shift;
-    my ($value, $tc, $tc_obj, $for_lazy) = @_;
+    my ($value, $tc, $message, $for_lazy) = @_;
 
     return unless $for_lazy || $self->_constraint_must_be_checked;
 

diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index cd41e58..ad19406 100644 (file)
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -85,15 +85,21 @@ sub _eval_environment {
             : undef
     } @type_constraints;
 
+    my @type_constraint_messages = map {
+        defined $_
+            ? ($_->has_message ? $_->message : $_->_default_message)
+            : undef
+    } @type_constraints;
+
     return {
         ((any { defined && $_->has_initializer } @$attrs)
             ? ('$attrs' => \$attrs)
             : ()),
         '$defaults' => \$defaults,
         '$triggers' => \$triggers,
-        '@type_constraints' => \@type_constraints,
         '@type_coercions' => \@type_coercions,
         '@type_constraint_bodies' => \@type_constraint_bodies,
+        '@type_constraint_messages' => \@type_constraint_messages,
         ( map { defined($_) ? %{ $_->inline_environment } : () }
               @type_constraints ),
         # pretty sure this is only going to be closed over if you use a custom