From: Jesse Luehrs Date: Thu, 11 Nov 2010 04:46:48 +0000 (-0600) Subject: push the accessor inlining code back into the attribute X-Git-Tag: 1.9900~35 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6e50f7e9f27e52d6816b9a726803bedf1b3127de;p=gitmo%2FMoose.git push the accessor inlining code back into the attribute --- diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 2532e32..64d7aef 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -52,6 +52,11 @@ sub throw_error { goto $handler; } +sub _inline_throw_error { + my ( $self, $msg, $args ) = @_; + "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard +} + sub new { my ($class, $name, %options) = @_; $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS @@ -546,6 +551,132 @@ sub set_value { } } +sub _inline_set_value { + my $self = shift; + my ($instance, $value) = @_; + + my $old = '@old'; + my $copy = '$val'; + + my @code; + if ($self->_writer_value_needs_copy) { + push @code, $self->_inline_copy_value($value, $copy); + $value = $copy; + } + + 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), + ); + + return @code; +} + +sub _writer_value_needs_copy { + my $self = shift; + return $self->should_coerce; +} + +sub _inline_copy_value { + my $self = shift; + my ($value, $copy) = @_; + + return 'my ' . $copy . ' = ' . $value . ';' +} + +sub _inline_check_required { + my $self = shift; + + return unless $self->is_required; + + my $attr_name = quotemeta($self->name); + + return ( + 'if (@_ < 2) {', + $self->_inline_throw_error( + '"Attribute (' . $attr_name . ') is required, so cannot ' + . 'be set to undef"' # defined $_[1] is not good enough + ) . ';', + '}', + ); +} + +sub _inline_tc_code { + my $self = shift; + return ( + $self->_inline_check_coercion(@_), + $self->_inline_check_constraint(@_), + ); +} + +sub _inline_check_coercion { + my $self = shift; + my ($value) = @_; + + return unless $self->should_coerce && $self->type_constraint->has_coercion; + + return $value . ' = $type_constraint_obj->coerce(' . $value . ');'; +} + +sub _inline_check_constraint { + my $self = shift; + my ($value) = @_; + + return unless $self->has_type_constraint; + + my $attr_name = quotemeta($self->name); + + return ( + 'if (!$type_constraint->(' . $value . ')) {', + $self->_inline_throw_error( + '"Attribute (' . $attr_name . ') does not pass the type ' + . 'constraint because: " . ' + . '$type_constraint_obj->get_message(' . $value . ')', + 'data => ' . $value + ) . ';', + '}', + ); +} + +sub _inline_get_old_value_for_trigger { + my $self = shift; + my ($instance, $old) = @_; + + return unless $self->has_trigger; + + return ( + 'my ' . $old . ' = ' . $self->_inline_instance_has($instance), + '? ' . $self->_inline_instance_get($instance), + ': ();', + ); +} + +sub _inline_weaken_value { + my $self = shift; + my ($instance, $value) = @_; + + return unless $self->is_weak_ref; + + my $mi = $self->associated_class->get_meta_instance; + return ( + $mi->inline_weaken_slot_value($instance, $self->name, $value), + 'if ref ' . $value . ';', + ); +} + +sub _inline_trigger { + my $self = shift; + my ($instance, $value, $old) = @_; + + return unless $self->has_trigger; + + return '$attr->trigger->(' . $instance . ', ' . $value . ', ' . $old . ');'; +} + sub _weaken_value { my ( $self, $instance ) = @_; @@ -598,6 +729,138 @@ sub get_value { } } +sub _inline_get_value { + my $self = shift; + my ($instance) = @_; + + my $slot_access = $self->_inline_instance_get($instance); + + return ( + $self->_inline_check_lazy($instance), + $self->_inline_return_auto_deref($slot_access), + ); +} + +sub _inline_check_lazy { + my $self = shift; + my ($instance, $default) = @_; + + return unless $self->is_lazy; + + my $slot_exists = $self->_inline_instance_has($instance); + + return ( + 'if (!' . $slot_exists . ') {', + $self->_inline_init_from_default($instance, '$default', 'lazy'), + '}', + ); +} + +sub _inline_init_from_default { + my $self = shift; + my ($instance, $default, $for_lazy) = @_; + + if (!($self->has_default || $self->has_builder)) { + $self->throw_error( + 'You cannot have a lazy attribute ' + . '(' . $self->name . ') ' + . 'without specifying a default value for it', + attr => $self, + ); + } + + return ( + $self->_inline_generate_default($instance, $default), + # intentionally not using _inline_tc_code, since that can be overridden + # 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_init_slot($instance, $default), + ); +} + +sub _inline_generate_default { + my $self = shift; + my ($instance, $default) = @_; + + if ($self->has_default) { + return 'my ' . $default . ' = $attr->default(' . $instance . ');'; + } + elsif ($self->has_builder) { + return ( + 'my ' . $default . ';', + 'if (my $builder = ' . $instance . '->can($attr->builder)) {', + $default . ' = ' . $instance . '->$builder;', + '}', + 'else {', + 'my $class = ref(' . $instance . ') || ' . $instance . ';', + 'my $builder_name = $attr->builder;', + 'my $attr_name = $attr->name;', + $self->_inline_throw_error( + '"$class does not support builder method ' + . '\'$builder_name\' for attribute \'$attr_name\'"' + ) . ';', + '}', + ); + } + else { + $self->throw_error( + "Can't generate a default for " . $self->name + . " since no default or builder was specified" + ); + } +} + +sub _inline_init_slot { + my $self = shift; + my ($inv, $value) = @_; + + if ($self->has_initializer) { + return '$attr->set_initial_value(' . $inv . ', ' . $value . ');'; + } + else { + return $self->_inline_instance_set($inv, $value) . ';'; + } +} + +sub _inline_return_auto_deref { + my $self = shift; + + return 'return ' . $self->_auto_deref(@_) . ';'; +} + +sub _auto_deref { + my $self = shift; + my ($ref_value) = @_; + + return $ref_value unless $self->should_auto_deref; + + my $type_constraint = $self->type_constraint; + + my $sigil; + if ($type_constraint->is_a_type_of('ArrayRef')) { + $sigil = '@'; + } + elsif ($type_constraint->is_a_type_of('HashRef')) { + $sigil = '%'; + } + else { + $self->throw_error( + 'Can not auto de-reference the type constraint \'' + . $type_constraint->name + . '\'', + type_constraint => $type_constraint, + ); + } + + return 'wantarray ' + . '? ' . $sigil . '{ (' . $ref_value . ') || return } ' + . ': (' . $ref_value . ')'; +} + ## installing accessors sub accessor_metaclass { 'Moose::Meta::Method::Accessor' } @@ -674,22 +937,6 @@ sub remove_accessors { return; } -sub _inline_set_value { - my $self = shift; - my ($instance, $value) = @_; - - my $mi = $self->associated_class->get_meta_instance; - - my @code = ($self->SUPER::_inline_set_value(@_)); - - push @code, ( - $mi->inline_weaken_slot_value($instance, $self->name, $value), - 'if ref ' . $value . ';', - ) if $self->is_weak_ref; - - return @code; -} - sub install_delegation { my $self = shift; diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm index 348c01b..b3f4b72 100644 --- a/lib/Moose/Meta/Method/Accessor.pm +++ b/lib/Moose/Meta/Method/Accessor.pm @@ -54,88 +54,6 @@ sub _eval_environment { }; } -sub _generate_accessor_method_inline { - my $self = shift; - - my $inv = '$_[0]'; - my $slot_access = $self->_get_value($inv); - my $value = $self->_value_needs_copy ? '$val' : '$_[1]'; - my $old = '@old'; - - $self->_compile_code([ - 'sub {', - $self->_inline_pre_body(@_), - 'if (scalar(@_) >= 2) {', - $self->_inline_copy_value($value), - $self->_inline_check_required, - $self->_inline_tc_code($value), - $self->_inline_get_old_value_for_trigger($inv, $old), - $self->_inline_store_value($inv, $value), - $self->_inline_trigger($inv, $value, $old), - '}', - $self->_inline_check_lazy($inv), - $self->_inline_post_body(@_), - $self->_inline_return_auto_deref($slot_access), - '}', - ]); -} - -sub _generate_writer_method_inline { - my $self = shift; - - my $inv = '$_[0]'; - my $value = $self->_value_needs_copy ? '$val' : '$_[1]'; - my $old = '@old'; - - $self->_compile_code([ - 'sub {', - $self->_inline_pre_body(@_), - $self->_inline_copy_value($value), - $self->_inline_check_required, - $self->_inline_tc_code($value), - $self->_inline_get_old_value_for_trigger($inv, $old), - $self->_inline_store_value($inv, $value), - $self->_inline_post_body(@_), - $self->_inline_trigger($inv, $value, $old), - '}', - ]); -} - -sub _generate_reader_method_inline { - my $self = shift; - - my $inv = '$_[0]'; - my $slot_access = $self->_get_value($inv); - - $self->_compile_code([ - 'sub {', - $self->_inline_pre_body(@_), - 'if (@_ > 1) {', - $self->_inline_throw_error( - '"Cannot assign a value to a read-only accessor"', - 'data => \@_' - ) . ';', - '}', - $self->_inline_check_lazy($inv), - $self->_inline_post_body(@_), - $self->_inline_return_auto_deref($slot_access), - '}', - ]); -} - -sub _inline_copy_value { - my $self = shift; - my ($value) = @_; - - return unless $self->_value_needs_copy; - return 'my ' . $value . ' = $_[1];' -} - -sub _value_needs_copy { - my $self = shift; - return $self->associated_attribute->should_coerce; -} - sub _instance_is_inlinable { my $self = shift; return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable; @@ -171,235 +89,40 @@ sub _generate_clearer_method { : $self->SUPER::_generate_clearer_method(@_); } -sub _inline_pre_body { return } -sub _inline_post_body { return } +sub _writer_value_needs_copy { + shift->associated_attribute->_writer_value_needs_copy(@_); +} sub _inline_tc_code { - my $self = shift; - return ( - $self->_inline_check_coercion(@_), - $self->_inline_check_constraint(@_), - ); + shift->associated_attribute->_inline_tc_code(@_); } sub _inline_check_constraint { - my $self = shift; - my ($value) = @_; - - my $attr = $self->associated_attribute; - return unless $attr->has_type_constraint; - - my $attr_name = quotemeta($attr->name); - - return ( - 'if (!$type_constraint->(' . $value . ')) {', - $self->_inline_throw_error( - '"Attribute (' . $attr_name . ') does not pass the type ' - . 'constraint because: " . ' - . '$type_constraint_obj->get_message(' . $value . ')', - 'data => ' . $value - ) . ';', - '}', - ); -} - -sub _inline_check_coercion { - my $self = shift; - my ($value) = @_; - - my $attr = $self->associated_attribute; - return unless $attr->should_coerce && $attr->type_constraint->has_coercion; - - return $value . ' = $type_constraint_obj->coerce(' . $value . ');'; -} - -sub _inline_check_required { - my $self = shift; - - my $attr = $self->associated_attribute; - return unless $attr->is_required; - - my $attr_name = quotemeta($attr->name); - - return ( - 'if (@_ < 2) {', - $self->_inline_throw_error( - '"Attribute (' . $attr_name . ') is required, so cannot ' - . 'be set to undef"' # defined $_[1] is not good enough - ) . ';', - '}', - ); + shift->associated_attribute->_inline_check_constraint(@_); } sub _inline_check_lazy { - my $self = shift; - my ($instance, $default) = @_; - - my $attr = $self->associated_attribute; - return unless $attr->is_lazy; - - my $slot_exists = $self->_has_value($instance); - - return ( - 'if (!' . $slot_exists . ') {', - $self->_inline_init_from_default($instance, '$default', 'lazy'), - '}', - ); -} - -sub _inline_init_from_default { - my $self = shift; - my ($instance, $default, $for_lazy) = @_; - - my $attr = $self->associated_attribute; - - if (!($attr->has_default || $attr->has_builder)) { - $self->throw_error( - 'You cannot have a lazy attribute ' - . '(' . $attr->name . ') ' - . 'without specifying a default value for it', - attr => $attr, - ); - } - - return ( - $self->_inline_generate_default($instance, $default), - # intentionally not using _inline_tc_code, since that can be overridden - # to do things like possibly only do member tc checks, which isn't - # appropriate for checking the result of a default - $attr->has_type_constraint - ? ($self->_inline_check_coercion($default, $for_lazy), - $self->_inline_check_constraint($default, $for_lazy)) - : (), - $self->_inline_init_slot($attr, $instance, $default), - ); -} - -sub _inline_generate_default { - my $self = shift; - my ($instance, $default) = @_; - - my $attr = $self->associated_attribute; - - if ($attr->has_default) { - return 'my ' . $default . ' = $attr->default(' . $instance . ');'; - } - elsif ($attr->has_builder) { - return ( - 'my ' . $default . ';', - 'if (my $builder = ' . $instance . '->can($attr->builder)) {', - $default . ' = ' . $instance . '->$builder;', - '}', - 'else {', - 'my $class = ref(' . $instance . ') || ' . $instance . ';', - 'my $builder_name = $attr->builder;', - 'my $attr_name = $attr->name;', - $self->_inline_throw_error( - '"$class does not support builder method ' - . '\'$builder_name\' for attribute \'$attr_name\'"' - ) . ';', - '}', - ); - } - else { - $self->throw_error( - "Can't generate a default for " . $attr->name - . " since no default or builder was specified" - ); - } -} - -sub _inline_init_slot { - my $self = shift; - my ($attr, $inv, $value) = @_; - - if ($attr->has_initializer) { - return '$attr->set_initial_value(' . $inv . ', ' . $value . ');'; - } - else { - return $self->_inline_store_value($inv, $value); - } + shift->associated_attribute->_inline_check_lazy(@_); } sub _inline_store_value { - my $self = shift; - my ($inv, $value) = @_; - - return $self->associated_attribute->_inline_set_value($inv, $value); + shift->associated_attribute->_inline_instance_set(@_) . ';'; } sub _inline_get_old_value_for_trigger { - my $self = shift; - my ($instance, $old) = @_; - - my $attr = $self->associated_attribute; - return unless $attr->has_trigger; - - return ( - 'my ' . $old . ' = ' . $self->_has_value($instance), - '? ' . $self->_get_value($instance), - ': ();', - ); + shift->associated_attribute->_inline_get_old_value_for_trigger(@_); } sub _inline_trigger { - my $self = shift; - my ($instance, $value, $old) = @_; - - my $attr = $self->associated_attribute; - return unless $attr->has_trigger; - - return '$attr->trigger->(' . $instance . ', ' . $value . ', ' . $old . ');'; -} - -sub _inline_return_auto_deref { - my $self = shift; - - return 'return ' . $self->_auto_deref(@_) . ';'; + shift->associated_attribute->_inline_trigger(@_); } -# expressions - sub _get_value { - my ($self, $instance) = @_; - - return $self->associated_attribute->_inline_instance_get($instance); + shift->associated_attribute->_inline_instance_get(@_); } sub _has_value { - my ($self, $instance) = @_; - - return $self->associated_attribute->_inline_instance_has($instance); -} - -sub _auto_deref { - my $self = shift; - my ($ref_value) = @_; - - my $attr = $self->associated_attribute; - return $ref_value unless $attr->should_auto_deref; - - my $type_constraint = $attr->type_constraint; - - my $sigil; - if ($type_constraint->is_a_type_of('ArrayRef')) { - $sigil = '@'; - } - elsif ($type_constraint->is_a_type_of('HashRef')) { - $sigil = '%'; - } - else { - $self->throw_error( - 'Can not auto de-reference the type constraint \'' - . $type_constraint->name - . '\'', - type_constraint => $type_constraint, - ); - } - - return 'wantarray ' - . '? ' . $sigil . '{ (' . $ref_value . ') || return } ' - . ': (' . $ref_value . ')'; + shift->associated_attribute->_inline_instance_has(@_); } 1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm index 5d3fdab..2e89b0b 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm @@ -37,7 +37,6 @@ sub _generate_method { return ( 'sub {', - $self->_inline_pre_body(@_), 'my ' . $inv . ' = shift;', $self->_inline_curried_arguments, $self->_inline_check_lazy($inv), @@ -49,7 +48,6 @@ sub _generate_method { # set 'else {', $self->_inline_writer_core($inv, $slot_access), - $self->_inline_post_body(@_), '}', '}', ); diff --git a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm index 2f9222d..f298031 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm @@ -45,7 +45,7 @@ sub _tc_member_type { return; } -sub _value_needs_copy { +sub _writer_value_needs_copy { my $self = shift; return $self->_constraint_must_be_checked diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm index d2a04dc..29c6e4a 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm @@ -40,7 +40,6 @@ sub _generate_method { return ( 'sub {', - $self->_inline_pre_body(@_), 'my ' . $inv . ' = shift;', $self->_inline_curried_arguments, $self->_inline_check_lazy($inv), @@ -52,7 +51,6 @@ sub _generate_method { # set 'else {', $self->_inline_writer_core($inv, $slot_access), - $self->_inline_post_body(@_), '}', '}', ); diff --git a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm index d892b0c..9df7ed2 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm @@ -21,7 +21,6 @@ sub _generate_method { return ( 'sub {', - $self->_inline_pre_body(@_), 'my ' . $inv . ' = shift;', $self->_inline_curried_arguments, $self->_inline_reader_core($inv, $slot_access, @_), @@ -38,7 +37,6 @@ sub _inline_reader_core { $self->_inline_process_arguments($inv, $slot_access), $self->_inline_check_arguments, $self->_inline_check_lazy($inv), - $self->_inline_post_body(@extra), $self->_inline_return_value($slot_access), ); } diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm b/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm index 37bf3f5..61d7fbf 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm @@ -44,7 +44,6 @@ sub _generate_method { return ( 'sub {', - $self->_inline_pre_body(@_), 'my ' . $inv . ' = shift;', $self->_inline_curried_arguments, 'if (@_ == 1 || @_ == 2) {', @@ -52,7 +51,6 @@ sub _generate_method { '}', 'elsif (@_ == 3) {', $self->_inline_writer_core($inv, $slot_access), - $self->_inline_post_body(@_), '}', 'else {', $self->_inline_check_argument_count, diff --git a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm index b5fc987..620cd94 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm @@ -23,11 +23,9 @@ sub _generate_method { return ( 'sub {', - $self->_inline_pre_body(@_), 'my ' . $inv . ' = shift;', $self->_inline_curried_arguments, $self->_inline_writer_core($inv, $slot_access), - $self->_inline_post_body(@_), '}', ); } @@ -73,7 +71,7 @@ sub _inline_check_arguments { return } sub _inline_coerce_new_values { return } -sub _value_needs_copy { +sub _writer_value_needs_copy { my $self = shift; return $self->_constraint_must_be_checked; @@ -103,7 +101,7 @@ sub _inline_copy_native_value { my $self = shift; my ($potential_ref) = @_; - return unless $self->_value_needs_copy; + return unless $self->_writer_value_needs_copy; my $code = 'my $potential = ' . ${$potential_ref} . ';'; @@ -150,7 +148,7 @@ sub _inline_set_new_value { my $self = shift; return $self->_inline_store_value(@_) - if $self->_value_needs_copy + if $self->_writer_value_needs_copy || !$self->_slot_access_can_be_inlined || !$self->_get_is_lvalue; diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm index 718a7bc..6e9ef96 100644 --- a/lib/Moose/Meta/Method/Constructor.pm +++ b/lib/Moose/Meta/Method/Constructor.pm @@ -327,7 +327,7 @@ sub _generate_slot_assignment { } else { push @source, ( - $attr->_inline_set_value('$instance', $value), + $attr->_inline_instance_set('$instance', $value) . ';', ); }