From: Dave Rolsky Date: Sat, 4 Jul 2009 23:28:25 +0000 (-0500) Subject: Implement passing the old value to a trigger when appropriate X-Git-Tag: 0.89~13 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3dda07f5f7daa01a13043a3e0e9ff928f6a0cb80;p=gitmo%2FMoose.git Implement passing the old value to a trigger when appropriate --- diff --git a/Changes b/Changes index c2983e9..96f4f38 100644 --- a/Changes +++ b/Changes @@ -22,6 +22,11 @@ next version - Add functions meta_class_alias and meta_attribute_alias for creating aliases for class and attribute metaclasses and metatraits. (doy) + * Moose::Meta::Attribute + * Moose::Meta::Method::Accessor + - A trigger now receives the old value as a second argument, if + the attribute had one. + 0.88 Fri Jul 24, 2009 * Moose::Manual::Contributing - Re-write the Moose::Manual::Contributing document to reflect diff --git a/lib/Moose.pm b/lib/Moose.pm index 44dc9e9..a7118c5 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -457,8 +457,10 @@ This is only legal if your C option is either C or C. The I option is a CODE reference which will be called after the value of the attribute is set. The CODE ref will be passed the -instance itself and the updated value. You B have a trigger on -a read-only attribute. +instance itself and the updated value. If the attribute already had a +value, this will be passed as the third value to the trigger. + +You B have a trigger on a read-only attribute. B Triggers will only fire when you B to the attribute, either in the constructor, or using the writer. Default and built values will diff --git a/lib/Moose/Manual/Attributes.pod b/lib/Moose/Manual/Attributes.pod index 0ff2b58..9c2aff9 100644 --- a/lib/Moose/Manual/Attributes.pod +++ b/lib/Moose/Manual/Attributes.pod @@ -458,11 +458,21 @@ set: sub _size_set { my ( $self, $size ) = @_; - warn $self->name, " size is now $size\n"; + my $msg = $self->name; + + if (@_) { + $msg .= " - old size was $_[0]"; + } + + $msg .= " - size is now $size"; + warn $msg. } -The trigger is called as a method, and receives the new value as its argument. -The trigger is called I the value is set. +The trigger is called I an attribute's value is set. It is +called as a method on the object, and receives the new and values as +its arguments. If the attribute had not previously been set at all, +then only the new value is passed. This lets you distinguish between +the case where the attribute had no value versus when it was C. This differs from an C method modifier in two ways. First, a trigger is only called when the attribute is set, as opposed to diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 637335a..33ec298 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -495,6 +495,11 @@ sub set_value { my $meta_instance = Class::MOP::Class->initialize(blessed($instance)) ->get_meta_instance; + my @old; + if ( $self->has_trigger && $self->has_value($instance) ) { + @old = $self->get_value($instance, 'for trigger'); + } + $meta_instance->set_slot_value($instance, $attr_name, $value); if (ref $value && $self->is_weak_ref) { @@ -502,12 +507,12 @@ sub set_value { } if ($self->has_trigger) { - $self->trigger->($instance, $value); + $self->trigger->($instance, $value, @old); } } sub get_value { - my ($self, $instance) = @_; + my ($self, $instance, $for_trigger) = @_; if ($self->is_lazy) { unless ($self->has_value($instance)) { @@ -524,7 +529,7 @@ sub get_value { } } - if ($self->should_auto_deref) { + if ( $self->should_auto_deref && ! $for_trigger ) { my $type_constraint = $self->type_constraint; diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm index 0cc5734..6b34973 100644 --- a/lib/Moose/Meta/Method/Accessor.pm +++ b/lib/Moose/Meta/Method/Accessor.pm @@ -34,7 +34,7 @@ sub _eval_code { : undef), }; - #warn "code for $attr_name =>\n" . $source . "\n"; + #warn "code for " . $attr->name . " =>\n" . $source . "\n"; my ( $code, $e ) = $self->_compile_code( environment => $environment, code => $source ); $self->throw_error( @@ -59,8 +59,9 @@ sub _generate_accessor_method_inline { . $self->_inline_check_required . "\n" . $self->_inline_check_coercion($value_name) . "\n" . $self->_inline_check_constraint($value_name) . "\n" + . $self->_inline_get_old_value_for_trigger($inv, $value_name) . "\n" . $self->_inline_store($inv, $value_name) . "\n" - . $self->_inline_trigger($inv, $value_name) . "\n" + . $self->_inline_trigger($inv, $value_name, '@old') . "\n" . ' }' . "\n" . $self->_inline_check_lazy($inv) . "\n" . $self->_inline_post_body(@_) . "\n" @@ -82,9 +83,10 @@ sub _generate_writer_method_inline { . $self->_inline_check_required . $self->_inline_check_coercion($value_name) . $self->_inline_check_constraint($value_name) + . $self->_inline_get_old_value_for_trigger($inv, $value_name) . "\n" . $self->_inline_store($inv, $value_name) . $self->_inline_post_body(@_) - . $self->_inline_trigger($inv, $value_name) + . $self->_inline_trigger($inv, $value_name, '@old') . ' }'); } @@ -226,11 +228,26 @@ sub _inline_store { return $code; } +sub _inline_get_old_value_for_trigger { + my ( $self, $instance ) = @_; + + my $attr = $self->associated_attribute; + return '' unless $attr->has_trigger; + + my $mi = $attr->associated_class->get_meta_instance; + my $pred = $mi->inline_is_slot_initialized($instance, $attr->name); + + return + 'my @old = ' + . $pred . q{ ? } + . $self->_inline_get($instance) . q{ : ()} . ";\n"; +} + sub _inline_trigger { - my ($self, $instance, $value) = @_; + my ($self, $instance, $value, $old_value) = @_; my $attr = $self->associated_attribute; return '' unless $attr->has_trigger; - return sprintf('$attr->trigger->(%s, %s);', $instance, $value); + return sprintf('$attr->trigger->(%s, %s, %s);', $instance, $value, $old_value); } sub _inline_get { diff --git a/t/020_attributes/004_attribute_triggers.t b/t/020_attributes/004_attribute_triggers.t index e799399..baa2a2a 100644 --- a/t/020_attributes/004_attribute_triggers.t +++ b/t/020_attributes/004_attribute_triggers.t @@ -5,7 +5,7 @@ use warnings; use Scalar::Util 'isweak'; -use Test::More tests => 40; +use Test::More tests => 42; use Test::Exception; @@ -158,7 +158,8 @@ use Test::Exception; is_deeply(\%Blarg::trigger_vals, { map { $_ => "Yet another $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values'); } -# Triggers do not receive the meta-attribute as an argument +# Triggers do not receive the meta-attribute as an argument, but do +# receive the old value { package Foo; @@ -169,6 +170,28 @@ use Test::Exception; { my $attr = Foo->meta->get_attribute('foo'); + + my $foo = Foo->new; + $attr->set_value( $foo, 2 ); + + is_deeply( + \@Foo::calls, + [ [ $foo, 2 ] ], + 'trigger called correctly on initial set via meta-API', + ); + @Foo::calls = (); + + $attr->set_value( $foo, 3 ); + + is_deeply( + \@Foo::calls, + [ [ $foo, 3, 2 ] ], + 'trigger called correctly on second set via meta-API', + ); + @Foo::calls = (); +} + +{ my $foo = Foo->new(foo => 2); is_deeply( \@Foo::calls, @@ -180,8 +203,8 @@ use Test::Exception; $foo->foo(3); is_deeply( \@Foo::calls, - [ [ $foo, 3 ] ], - 'trigger called correctly on set', + [ [ $foo, 3, 2 ] ], + 'trigger called correctly on set (with old value)', ); @Foo::calls = (); Foo->meta->make_immutable, redo if Foo->meta->is_mutable;