From: gfx Date: Sat, 1 Aug 2009 05:38:07 +0000 (+0900) Subject: Move attribute triggers from Moose, breaking no compatibility X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7813a0c5d3003a9604d810184231b09f3e206023;p=gitmo%2FClass-MOP.git Move attribute triggers from Moose, breaking no compatibility This will be used for future enhancement. --- diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 582d7fd..d36025c 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -52,6 +52,13 @@ sub new { confess("A required attribute must have either 'init_arg', 'builder', or 'default'"); } + if(exists $options{trigger}){ + ( ref($options{trigger}) + ? (ref($options{trigger}) eq 'CODE') + :(defined $options{trigger} && length $options{trigger}) ) + || confess("Trigger must be a CODE ref or method name on attribute ($name)"); + } + $class->_new(\%options); } @@ -75,6 +82,7 @@ sub _new { 'default' => $options->{default}, 'initializer' => $options->{initializer}, 'definition_context' => $options->{definition_context}, + 'trigger' => $options->{trigger}, # keep a weakened link to the # class we are associated with 'associated_class' => undef, @@ -142,8 +150,11 @@ sub _set_initial_slot_value { my $slot_name = $self->name; - return $meta_instance->set_slot_value($instance, $slot_name, $value) - unless $self->has_initializer; + unless($self->has_initializer){ + $meta_instance->set_slot_value($instance, $slot_name, $value); + $self->call_trigger($instance, $value); + return; + } my $callback = sub { $meta_instance->set_slot_value($instance, $slot_name, $_[0]); @@ -153,6 +164,8 @@ sub _set_initial_slot_value { # most things will just want to set a value, so make it first arg $instance->$initializer($value, $callback, $self); + $self->call_trigger($instance, $value); + return; } # NOTE: @@ -172,6 +185,7 @@ sub has_init_arg { defined($_[0]->{'init_arg'}) } sub has_default { defined($_[0]->{'default'}) } sub has_initializer { defined($_[0]->{'initializer'}) } sub has_insertion_order { defined($_[0]->{'insertion_order'}) } +sub has_trigger { defined($_[0]->{'trigger'}) } sub accessor { $_[0]->{'accessor'} } sub reader { $_[0]->{'reader'} } @@ -184,13 +198,24 @@ sub initializer { $_[0]->{'initializer'} } sub definition_context { $_[0]->{'definition_context'} } sub insertion_order { $_[0]->{'insertion_order'} } sub _set_insertion_order { $_[0]->{'insertion_order'} = $_[1] } +sub trigger { $_[0]->{'trigger'} } + +sub call_trigger{ + my($self, $instance, $value) = @_; + if(defined(my $trigger = $self->{trigger})){ + $instance->$trigger($value); + } + return; +} # end bootstrapped away method section. # (all methods below here are kept intact) sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor } sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor } + + sub get_read_method { my $self = shift; my $reader = $self->reader || $self->accessor; @@ -303,6 +328,7 @@ sub set_initial_value { $instance, $value ); + return; } sub set_value { @@ -311,6 +337,8 @@ sub set_value { Class::MOP::Class->initialize(ref($instance)) ->get_meta_instance ->set_slot_value($instance, $self->name, $value); + $self->call_trigger($instance, $value); + return; } sub get_value { @@ -335,6 +363,8 @@ sub clear_value { Class::MOP::Class->initialize(ref($instance)) ->get_meta_instance ->deinitialize_slot($instance, $self->name); + $self->call_trigger($instance); + return; } ## load em up ... diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index 09e4af6..26207aa 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -164,6 +164,16 @@ sub _generate_clearer_method { ## Inline methods + +sub _inline_call_trigger { + my ($self, $attr, $instance, $value) = @_; + return '' unless $attr->has_trigger; + return defined($value) + ? sprintf('$attr->call_trigger(%s, %s);', $instance, $value) + : sprintf('$attr->call_trigger(%s);', $instance); +} + + sub generate_accessor_method_inline { Carp::cluck('The generate_accessor_method_inline method has been made private.' . " The public version is deprecated and will be removed in a future release.\n"); @@ -177,10 +187,12 @@ sub _generate_accessor_method_inline { my $meta_instance = $attr->associated_class->instance_metaclass; my ( $code, $e ) = $self->_eval_closure( - {}, + {'$attr' => \$attr}, 'sub {' - . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]') - . ' if scalar(@_) == 2; ' + . 'if(scalar(@_) == 2){' + . 'my $value = ' . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]') . ';' + . $self->_inline_call_trigger($attr, '$_[0]', '$value') + . '}' . $meta_instance->inline_get_slot_value('$_[0]', $attr_name) . '}' ); @@ -226,9 +238,11 @@ sub _generate_writer_method_inline { my $meta_instance = $attr->associated_class->instance_metaclass; my ( $code, $e ) = $self->_eval_closure( - {}, + {'$attr' => \$attr}, 'sub {' - . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]') + . 'my $value = ' . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]') . ';' + . $self->_inline_call_trigger($attr, '$_[0]', '$value') + . 'return $value;' . '}' ); confess "Could not generate inline writer because : $e" if $e; @@ -272,10 +286,12 @@ sub _generate_clearer_method_inline { my $meta_instance = $attr->associated_class->instance_metaclass; my ( $code, $e ) = $self->_eval_closure( - {}, + {'$attr' => \$attr}, 'sub {' - . $meta_instance->inline_deinitialize_slot('$_[0]', $attr_name) - . '}' + . $meta_instance->inline_deinitialize_slot('$_[0]', $attr_name) . ';' + . $self->_inline_call_trigger($attr, '$_[0]') + . 'return;' + . '}', ); confess "Could not generate inline clearer because : $e" if $e; diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm index b69cea3..4a6b9f2 100644 --- a/lib/Class/MOP/Method/Constructor.pm +++ b/lib/Class/MOP/Method/Constructor.pm @@ -122,6 +122,19 @@ sub _generate_constructor_method { return sub { Class::MOP::Class->initialize(shift)->new_object(@_) } } +sub _inline_set_slot_value{ + my($self,$attr, $instance, $attr_var, $value) = @_; + + if($attr->has_trigger){ + return sprintf q{ my $value = %s; %s->call_trigger(%s, $value); }, + $self->_meta_instance->inline_set_slot_value($instance, $attr->name, $value), + $attr_var, $instance, $value; + } + else{ + return $self->_meta_instance->inline_set_slot_value($instance, $attr->name, $value); + } +} + sub generate_constructor_method_inline { Carp::cluck('The generate_constructor_method_inline method has been made private.' . " The public version is deprecated and will be removed in a future release.\n"); @@ -163,6 +176,13 @@ sub _generate_slot_initializer { my $attr = shift; my $close = shift; + + my $attr_var = do{ + my $attrs = ($close->{'@attrs'} ||= []); + push @{$attrs}, $attr; + sprintf q{$attrs[%d]}, scalar(@{$attrs}) - 1; + }; + my $default; if ($attr->has_default) { # NOTE: @@ -190,22 +210,25 @@ sub _generate_slot_initializer { if ( defined(my $init_arg = $attr->init_arg) ) { return ( 'if(exists $params->{\'' . $init_arg . '\'}){' . "\n" . - $self->_meta_instance->inline_set_slot_value( + $self->_inline_set_slot_value( + $attr, '$instance', - $attr->name, + $attr_var, '$params->{\'' . $init_arg . '\'}' ) . "\n" . '} ' . (!defined $default ? '' : 'else {' . "\n" . - $self->_meta_instance->inline_set_slot_value( + $self->_inline_set_slot_value( + $attr, '$instance', - $attr->name, + $attr_var, $default ) . "\n" . '}') ); } elsif ( defined $default ) { return ( - $self->_meta_instance->inline_set_slot_value( + $self->_inline_set_slot_value( + $attr, '$instance', - $attr->name, + $attr_var, $default ) . "\n" ); } else { return '' } diff --git a/lib/Class/MOP/Method/Generated.pm b/lib/Class/MOP/Method/Generated.pm index 76f1ce6..9b8ffbb 100644 --- a/lib/Class/MOP/Method/Generated.pm +++ b/lib/Class/MOP/Method/Generated.pm @@ -12,6 +12,8 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Method'; +use constant _EVAL_REPORT => $ENV{MOP_EVAL_REPORT} ? 1 : 0; + ## accessors sub new { @@ -31,11 +33,12 @@ sub _eval_closure { my $__captures = $_[1]; my $code; + my $src; my $e = do { local $@; local $SIG{__DIE__}; - $code = eval join + $code = eval($src = join "\n", ( map { /^([\@\%\$])/ @@ -47,10 +50,12 @@ sub _eval_closure { . $_ . q['}};]; } keys %$__captures ), - $_[2]; + $_[2]); $@; }; + print '#', $_[0]->name, "\n", $src , "\n" if _EVAL_REPORT; + return ( $code, $e ); } diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t index 34b09cc..ec3298e 100644 --- a/t/014_attribute_introspection.t +++ b/t/014_attribute_introspection.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 69; +use Test::More tests => 72; use Test::Exception; use Class::MOP; @@ -35,6 +35,7 @@ use Class::MOP; has_default default is_default_a_coderef has_initializer initializer has_insertion_order insertion_order _set_insertion_order + has_trigger trigger call_trigger definition_context diff --git a/t/088_attribute_triggers.t b/t/088_attribute_triggers.t new file mode 100755 index 0000000..2a01ec9 --- /dev/null +++ b/t/088_attribute_triggers.t @@ -0,0 +1,114 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 40; +use Test::Exception; + +my $bar_set; +my $baz_set; +{ + package Foo; + use metaclass; + + sub new{ + my($class, @args) = @_; + return $class->meta->new_object(@args); + } + + ::lives_ok{ + __PACKAGE__->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + predicate => 'has_bar', + clearer => 'clear_bar', + + trigger => sub { + my ($self, $bar) = @_; + $bar_set = $bar; + }); + }; + + ::lives_ok{ + __PACKAGE__->meta->add_attribute('baz' => + accessor => 'baz', + predicate => 'has_baz', + clearer => 'clear_baz', + trigger => '_baz_set', + ); + }; + + sub _baz_set { + my ($self, $baz) = @_; + $baz_set = $baz; + } +} + +TEST:{ + my $foo = Foo->new(bar => '*bar*', baz => '*baz*'); + + isa_ok $foo, 'Foo'; + + is $foo->get_bar, '*bar*'; + is $foo->baz, '*baz*'; + + is $bar_set, '*bar*', 'trigger (CODE ref) on initialization'; + is $baz_set, '*baz*', 'trigger (method name) on initialization'; + + $foo->set_bar('_bar_'); + $foo->baz('_baz_'); + + is $foo->get_bar, '_bar_'; + is $foo->baz, '_baz_'; + + is $bar_set, '_bar_', 'trigger (CODE ref) on the writer'; + is $baz_set, '_baz_', 'trigger (method name) on the writer'; + + ok $foo->has_bar(); + ok $foo->has_baz(); + + is $bar_set, '_bar_', 'trigger (CODE ref) not called on the predicate'; + is $baz_set, '_baz_', 'trigger (method name) not called on the predicate'; + + $foo->clear_bar(); + $foo->clear_baz(); + + is $bar_set, undef, 'trigger (CODE ref) called on the clearer'; + is $baz_set, undef, 'trigger (method name) called on the clearer'; + + ok !$foo->has_bar(); + ok !$foo->has_baz(); + + + if($foo->meta->is_mutable){ + ok $foo->meta->make_immutable(replace_constructor => 1), 'make_immutable()'; + redo TEST; + } +} + +# edge cases +{ + package XXX; + use metaclass; + + ::throws_ok{ + __PACKAGE__->meta->add_attribute(fail => + trigger => {}, + ); + } qr/trigger/; + + ::throws_ok{ + __PACKAGE__->meta->add_attribute(fail => + trigger => [], + ); + } qr/trigger/; + + + ::throws_ok{ + __PACKAGE__->meta->add_attribute(fail => + trigger => undef, + ); + } qr/trigger/; +} +