From: Jesse Luehrs Date: Mon, 25 Apr 2011 18:39:50 +0000 (-0500) Subject: stop closing over the type constraint object X-Git-Tag: 2.0100~26 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a619fc2f7e80a7c8fc55c2e53ce5f4c98ad44dc8;p=gitmo%2FMoose.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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