This will be used for future enhancement.
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);
}
'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,
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]);
# 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:
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'} }
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;
$instance,
$value
);
+ return;
}
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 {
Class::MOP::Class->initialize(ref($instance))
->get_meta_instance
->deinitialize_slot($instance, $self->name);
+ $self->call_trigger($instance);
+ return;
}
## load em up ...
## 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");
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)
. '}'
);
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;
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;
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");
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:
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 '' }
use base 'Class::MOP::Method';
+use constant _EVAL_REPORT => $ENV{MOP_EVAL_REPORT} ? 1 : 0;
+
## accessors
sub new {
my $__captures = $_[1];
my $code;
+ my $src;
my $e = do {
local $@;
local $SIG{__DIE__};
- $code = eval join
+ $code = eval($src = join
"\n", (
map {
/^([\@\%\$])/
. $_ . q['}};];
} keys %$__captures
),
- $_[2];
+ $_[2]);
$@;
};
+ print '#', $_[0]->name, "\n", $src , "\n" if _EVAL_REPORT;
+
return ( $code, $e );
}
use strict;
use warnings;
-use Test::More tests => 69;
+use Test::More tests => 72;
use Test::Exception;
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
--- /dev/null
+#!/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/;
+}
+
projects / gitmo/Class-MOP.git / commitdiff