From: Jesse Luehrs Date: Mon, 25 Apr 2011 05:18:48 +0000 (-0500) Subject: close over the coercion sub separately X-Git-Tag: 2.0100~32 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c40e4359e7a5ad21af41e42c5a3746c193da9777;p=gitmo%2FMoose.git close over the coercion sub separately --- diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 53504bd..e6d5172 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -551,12 +551,13 @@ sub set_value { sub _inline_set_value { my $self = shift; - my ($instance, $value, $tc, $tc_obj, $for_constructor) = @_; + my ($instance, $value, $tc, $coercion, $tc_obj, $for_constructor) = @_; - my $old = '@old'; - my $copy = '$val'; - $tc ||= '$type_constraint'; - $tc_obj ||= '$type_constraint_obj'; + my $old = '@old'; + my $copy = '$val'; + $tc ||= '$type_constraint'; + $coercion ||= '$type_coercion'; + $tc_obj ||= '$type_constraint_obj'; my @code; if ($self->_writer_value_needs_copy) { @@ -568,7 +569,7 @@ sub _inline_set_value { push @code, $self->_inline_check_required unless $for_constructor; - push @code, $self->_inline_tc_code($value, $tc, $tc_obj); + push @code, $self->_inline_tc_code($value, $tc, $coercion, $tc_obj); # constructors do triggers all at once at the end push @code, $self->_inline_get_old_value_for_trigger($instance, $old) @@ -617,19 +618,37 @@ sub _inline_check_required { sub _inline_tc_code { my $self = shift; + my ($value, $tc, $coercion, $tc_obj, $is_lazy) = @_; return ( - $self->_inline_check_coercion(@_), - $self->_inline_check_constraint(@_), + $self->_inline_check_coercion( + $value, $tc, $coercion, $is_lazy, + ), + $self->_inline_check_constraint( + $value, $tc, $tc_obj, $is_lazy, + ), ); } sub _inline_check_coercion { my $self = shift; - my ($value, $tc, $tc_obj) = @_; + my ($value, $tc, $coercion) = @_; return unless $self->should_coerce && $self->type_constraint->has_coercion; - return $value . ' = ' . $tc_obj . '->coerce(' . $value . ');'; + if ( $self->type_constraint->can_be_inlined ) { + return ( + 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {', + $value . ' = ' . $coercion . '->(' . $value . ');', + '}', + ); + } + else { + return ( + 'if (!' . $tc . '->(' . $value . ')) {', + $value . ' = ' . $coercion . '->(' . $value . ');', + '}', + ); + } } sub _inline_check_constraint { @@ -755,21 +774,22 @@ sub get_value { sub _inline_get_value { my $self = shift; - my ($instance, $tc, $tc_obj) = @_; + my ($instance, $tc, $coercion, $tc_obj) = @_; my $slot_access = $self->_inline_instance_get($instance); $tc ||= '$type_constraint'; + $coercion ||= '$type_coercion'; $tc_obj ||= '$type_constraint_obj'; return ( - $self->_inline_check_lazy($instance, $tc, $tc_obj), + $self->_inline_check_lazy($instance, $tc, $coercion, $tc_obj), $self->_inline_return_auto_deref($slot_access), ); } sub _inline_check_lazy { my $self = shift; - my ($instance, $tc, $tc_obj) = @_; + my ($instance, $tc, $coercion, $tc_obj) = @_; return unless $self->is_lazy; @@ -777,14 +797,14 @@ sub _inline_check_lazy { return ( 'if (!' . $slot_exists . ') {', - $self->_inline_init_from_default($instance, '$default', $tc, $tc_obj, 'lazy'), + $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $tc_obj, 'lazy'), '}', ); } sub _inline_init_from_default { my $self = shift; - my ($instance, $default, $tc, $tc_obj, $for_lazy) = @_; + my ($instance, $default, $tc, $coercion, $tc_obj, $for_lazy) = @_; if (!($self->has_default || $self->has_builder)) { $self->throw_error( @@ -801,7 +821,7 @@ sub _inline_init_from_default { # to do things like possibly only do member tc checks, which isn't # appropriate for checking the result of a default $self->has_type_constraint - ? ($self->_inline_check_coercion($default, $tc, $tc_obj, $for_lazy), + ? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy), $self->_inline_check_constraint($default, $tc, $tc_obj, $for_lazy)) : (), $self->_inline_init_slot($instance, $default), diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index a0e242a..3a2ebe2 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -381,6 +381,7 @@ sub _inline_init_attr_from_constructor { '$instance', '$params->{\'' . $attr->init_arg . '\'}', '$type_constraint_bodies[' . $idx . ']', + '$type_coercions[' . $idx . ']', '$type_constraints[' . $idx . ']', 'for constructor', ); @@ -409,6 +410,7 @@ sub _inline_init_attr_from_default { '$instance', '$default', '$type_constraint_bodies[' . $idx . ']', + '$type_coercions[' . $idx . ']', '$type_constraints[' . $idx . ']', 'for constructor', ), diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm index 44b1242..8601487 100644 --- a/lib/Moose/Meta/Method/Accessor.pm +++ b/lib/Moose/Meta/Method/Accessor.pm @@ -47,11 +47,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 used for coercions - # and the tc message, is there a way to inline those too? + # 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; + + $env->{'$type_constraint'} = \( + $tc_obj->_compiled_type_constraint + ) unless $tc_obj->can_be_inlined; + $env->{'$type_coercion'} = \( + $tc_obj->coercion->_compiled_type_coercion + ) if $tc_obj->has_coercion; $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 0952cad..941e00c 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_constraint_obj'), + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'), # 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 d06ae03..8d63951 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm @@ -50,6 +50,7 @@ sub _writer_value_needs_copy { sub _inline_tc_code { my $self = shift; + my ($value, $tc, $coercion, $tc_obj, $is_lazy) = @_; return unless $self->_constraint_must_be_checked; @@ -60,8 +61,8 @@ sub _inline_tc_code { } else { return ( - $self->_inline_check_coercion(@_), - $self->_inline_check_constraint(@_), + $self->_inline_check_coercion($value, $tc, $coercion, $is_lazy), + $self->_inline_check_constraint($value, $tc, $tc_obj, $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 1b8eafd..3a5de7f 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_constraint_obj'), + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'), # 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 4084c92..9d08fb8 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_constraint_obj'), + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'), $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 165c619..1ea3ced 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_constraint_obj'), + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'), ); 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_constraint_obj'), + $self->_inline_tc_code($potential, '$type_constraint', '$type_coercion', '$type_constraint_obj'), $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, $tc_obj, $for_lazy) = @_; + my ($value, $tc, $coercion, $tc_obj, $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 693c822..6b1d7c2 100644 --- a/lib/Moose/Meta/Method/Constructor.pm +++ b/lib/Moose/Meta/Method/Constructor.pm @@ -74,11 +74,18 @@ sub _eval_environment { defined $_ ? $_->_compiled_type_constraint : undef; } @type_constraints; + my @type_coercions = map { + defined $_ && $_->has_coercion + ? $_->coercion->_compiled_type_coercion + : undef + } @type_constraints; + return { '$meta' => \$self, '$attrs' => \$attrs, '$defaults' => \$defaults, '@type_constraints' => \@type_constraints, + '@type_coercions' => \@type_coercions, '@type_constraint_bodies' => \@type_constraint_bodies, ( map { defined($_) ? %{ $_->inline_environment } : () } @type_constraints ),