From: Jesse Luehrs Date: Thu, 11 Nov 2010 16:54:37 +0000 (-0600) Subject: refactor constructor inlining to reuse attribute code X-Git-Tag: 1.9900~31 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ec86bdff10923f63141e6529c2178189a64c71b8;p=gitmo%2FMoose.git refactor constructor inlining to reuse attribute code --- diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 64d7aef..f76257a 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -553,10 +553,12 @@ sub set_value { sub _inline_set_value { my $self = shift; - my ($instance, $value) = @_; + my ($instance, $value, $tc, $tc_obj, $for_constructor) = @_; - my $old = '@old'; - my $copy = '$val'; + my $old = '@old'; + my $copy = '$val'; + $tc ||= '$type_constraint'; + $tc_obj ||= '$type_constraint_obj'; my @code; if ($self->_writer_value_needs_copy) { @@ -564,15 +566,25 @@ sub _inline_set_value { $value = $copy; } + # constructors already handle required checks + push @code, $self->_inline_check_required + unless $for_constructor; + + push @code, $self->_inline_tc_code($value, $tc, $tc_obj); + + # constructors do triggers all at once at the end + push @code, $self->_inline_get_old_value_for_trigger($instance, $old) + unless $for_constructor; + push @code, ( - $self->_inline_check_required, - $self->_inline_tc_code($value), - $self->_inline_get_old_value_for_trigger($instance, $old), $self->SUPER::_inline_set_value($instance, $value), $self->_inline_weaken_value($instance, $value), - $self->_inline_trigger($instance, $value, $old), ); + # constructors do triggers all at once at the end + push @code, $self->_inline_trigger($instance, $value, $old) + unless $for_constructor; + return @code; } @@ -615,27 +627,27 @@ sub _inline_tc_code { sub _inline_check_coercion { my $self = shift; - my ($value) = @_; + my ($value, $tc, $tc_obj) = @_; return unless $self->should_coerce && $self->type_constraint->has_coercion; - return $value . ' = $type_constraint_obj->coerce(' . $value . ');'; + return $value . ' = ' . $tc_obj . '->coerce(' . $value . ');'; } sub _inline_check_constraint { my $self = shift; - my ($value) = @_; + my ($value, $tc, $tc_obj) = @_; return unless $self->has_type_constraint; my $attr_name = quotemeta($self->name); return ( - 'if (!$type_constraint->(' . $value . ')) {', + 'if (!' . $tc . '->(' . $value . ')) {', $self->_inline_throw_error( '"Attribute (' . $attr_name . ') does not pass the type ' . 'constraint because: " . ' - . '$type_constraint_obj->get_message(' . $value . ')', + . $tc_obj . '->get_message(' . $value . ')', 'data => ' . $value ) . ';', '}', @@ -731,19 +743,21 @@ sub get_value { sub _inline_get_value { my $self = shift; - my ($instance) = @_; + my ($instance, $tc, $tc_obj) = @_; my $slot_access = $self->_inline_instance_get($instance); + $tc ||= '$type_constraint'; + $tc_obj ||= '$type_constraint_obj'; return ( - $self->_inline_check_lazy($instance), + $self->_inline_check_lazy($instance, $tc, $tc_obj), $self->_inline_return_auto_deref($slot_access), ); } sub _inline_check_lazy { my $self = shift; - my ($instance, $default) = @_; + my ($instance, $tc, $tc_obj) = @_; return unless $self->is_lazy; @@ -751,14 +765,14 @@ sub _inline_check_lazy { return ( 'if (!' . $slot_exists . ') {', - $self->_inline_init_from_default($instance, '$default', 'lazy'), + $self->_inline_init_from_default($instance, '$default', $tc, $tc_obj, 'lazy'), '}', ); } sub _inline_init_from_default { my $self = shift; - my ($instance, $default, $for_lazy) = @_; + my ($instance, $default, $tc, $tc_obj, $for_lazy) = @_; if (!($self->has_default || $self->has_builder)) { $self->throw_error( @@ -775,8 +789,8 @@ 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, $for_lazy), - $self->_inline_check_constraint($default, $for_lazy)) + ? ($self->_inline_check_coercion($default, $tc, $tc_obj, $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 4f46020..1477590 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -338,34 +338,13 @@ sub _inline_BUILDARGS { sub _inline_slot_initializer { my $self = shift; - my ($attr, $index) = @_; + my ($attr, $idx) = @_; - my @source = ('## ' . $attr->name); - - push @source, $self->_inline_check_required_attr($attr); - - if (defined $attr->init_arg) { - push @source, - 'if (exists $params->{\'' . $attr->init_arg . '\'}) {', - $self->_inline_init_attr_from_constructor($attr, $index), - '}'; - if (my @default = $self->_inline_init_attr_from_default($attr, $index)) { - push @source, - 'else {', - @default, - '}'; - } - } - else { - if (my @default = $self->_inline_init_attr_from_default($attr, $index)) { - push @source, - '{', # _init_attr_from_default creates variables - @default, - '}'; - } - } - - return @source; + return ( + '## ' . $attr->name, + $self->_inline_check_required_attr($attr), + $self->SUPER::_inline_slot_initializer(@_), + ); } sub _inline_check_required_attr { @@ -387,98 +366,52 @@ sub _inline_check_required_attr { sub _inline_init_attr_from_constructor { my $self = shift; - my ($attr, $index) = @_; - - return ( - 'my $val = $params->{\'' . $attr->init_arg . '\'};', - $self->_inline_slot_assignment($attr, $index, '$val'), + my ($attr, $idx) = @_; + + my @initial_value = $attr->_inline_set_value( + '$instance', + '$params->{\'' . $attr->init_arg . '\'}', + '$type_constraint_bodies[' . $idx . ']', + '$type_constraints[' . $idx . ']', + 'for constructor', ); -} - -sub _inline_init_attr_from_default { - my $self = shift; - my ($attr, $index) = @_; - my $default = $self->_inline_default_value($attr, $index); - return unless $default; + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; - return ( - 'my $val = ' . $default . ';', - $self->_inline_slot_assignment($attr, $index, '$val'), - ); + return @initial_value; } -sub _inline_slot_assignment { - my $self = shift; - my ($attr, $index, $value) = @_; - - my @source; - - push @source, $self->_inline_type_constraint_and_coercion( - $attr, $index, $value, - ); - - if ($attr->has_initializer) { - push @source, ( - '$attrs->[' . $index . ']->set_initial_value(', - '$instance' . ',', - $value . ',', - ');' - ); - } - else { - push @source, ( - $attr->_inline_instance_set('$instance', $value) . ';', - ); - } - - return @source; -} - -sub _inline_type_constraint_and_coercion { +sub _inline_init_attr_from_default { my $self = shift; - my ($attr, $index, $value) = @_; - - return unless $attr->can('has_type_constraint') - && $attr->has_type_constraint; - - my @source; + my ($attr, $idx) = @_; - if ($attr->should_coerce && $attr->type_constraint->has_coercion) { - push @source => $self->_inline_type_coercion( - '$type_constraints[' . $index . ']', - $value, - $value, - ); - } + my $default = $self->_inline_default_value($attr, $idx); + return unless $default; - push @source => $self->_inline_type_constraint_check( - $attr, - '$type_constraint_bodies[' . $index . ']', - '$type_constraints[' . $index . ']', - $value, + my @initial_value = ( + 'my $default = ' . $default . ';', + $attr->_inline_set_value( + '$instance', + '$default', + '$type_constraint_bodies[' . $idx . ']', + '$type_constraints[' . $idx . ']', + 'for constructor', + ), ); - return @source; -} - -sub _inline_type_coercion { - my $self = shift; - my ($tc_obj, $value, $return_value) = @_; - return $return_value . ' = ' . $tc_obj . '->coerce(' . $value . ');'; -} + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; -sub _inline_type_constraint_check { - my $self = shift; - my ($attr, $tc_body, $tc_obj, $value) = @_; - return ( - $self->_inline_throw_error( - '"Attribute (' . quotemeta($attr->name) . ') ' - . 'does not pass the type constraint because: " . ' - . $tc_obj . '->get_message(' . $value . ')' - ), - 'unless ' . $tc_body . '->(' . $value . ');' - ); + return @initial_value; } sub _inline_extra_init { @@ -493,7 +426,7 @@ sub _inline_triggers { my $self = shift; my @trigger_calls; - my @attrs = $self->get_all_attributes; + my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; for my $i (0 .. $#attrs) { my $attr = $attrs[$i]; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm index 2e89b0b..5fe6fe4 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm @@ -39,7 +39,7 @@ sub _generate_method { 'sub {', 'my ' . $inv . ' = shift;', $self->_inline_curried_arguments, - $self->_inline_check_lazy($inv), + $self->_inline_check_lazy($inv, '$type_constraint', '$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 f298031..5e75523 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm @@ -54,7 +54,6 @@ sub _writer_value_needs_copy { sub _inline_tc_code { my $self = shift; - my ($potential_value) = @_; return unless $self->_constraint_must_be_checked; @@ -65,8 +64,8 @@ sub _inline_tc_code { } else { return ( - $self->_inline_check_coercion($potential_value), - $self->_inline_check_constraint($potential_value), + $self->_inline_check_coercion(@_), + $self->_inline_check_constraint(@_), ); } } diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm index 29c6e4a..0e0901a 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm @@ -42,7 +42,7 @@ sub _generate_method { 'sub {', 'my ' . $inv . ' = shift;', $self->_inline_curried_arguments, - $self->_inline_check_lazy($inv), + $self->_inline_check_lazy($inv, '$type_constraint', '$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 9df7ed2..564e4da 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm @@ -36,7 +36,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), + $self->_inline_check_lazy($inv, '$type_constraint', '$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 620cd94..12230ca 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm @@ -42,7 +42,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), + $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'), ); if ($self->_return_value($slot_access)) { @@ -54,7 +54,7 @@ sub _inline_writer_core { push @code, ( $self->_inline_coerce_new_values, $self->_inline_copy_native_value(\$potential), - $self->_inline_tc_code($potential), + $self->_inline_tc_code($potential, '$type_constraint', '$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), @@ -113,7 +113,7 @@ sub _inline_copy_native_value { around _inline_tc_code => sub { my $orig = shift; my $self = shift; - my ($value, $for_lazy) = @_; + my ($value, $tc, $tc_obj, $for_lazy) = @_; return unless $for_lazy || $self->_constraint_must_be_checked; @@ -122,20 +122,20 @@ around _inline_tc_code => sub { sub _inline_check_coercion { my $self = shift; - my ($value) = @_; + my ($value, $tc, $tc_obj) = @_; my $attr = $self->associated_attribute; return unless $attr->should_coerce && $attr->type_constraint->has_coercion; # We want to break the aliasing in @_ in case the coercion tries to make a # destructive change to an array member. - return $value . ' = $type_constraint_obj->coerce(' . $value . ');'; + return $value . ' = ' . $tc_obj . '->coerce(' . $value . ');'; } around _inline_check_constraint => sub { my $orig = shift; my $self = shift; - my ($value, $for_lazy) = @_; + my ($value, $tc, $tc_obj, $for_lazy) = @_; return unless $for_lazy || $self->_constraint_must_be_checked;