}
if (exists $options->{trigger}) {
- ('CODE' eq ref $options->{trigger})
- || confess "Trigger must be a CODE ref on attribute ($name)";
+ my $trig = $options->{trigger};
+ if ('HASH' eq ref $trig) {
+ my $legal = qr{^(?:before|after|around)$};
+ foreach my $key (keys %$trig) {
+ ($key =~ $legal)
+ || confess "$key is an illegal trigger specifier"
+ . " on attribute ($name)";
+ ('CODE' eq ref $trig->{$key})
+ || confess "$key trigger must be CODE ref"
+ . " on attribute ($name)";
+ }
+ }
+ elsif ('CODE' ne ref $trig) {
+ confess "Trigger must be a CODE or HASH ref on attribute ($name)";
+ }
}
if (exists $options->{auto_deref} && $options->{auto_deref}) {
}
+sub _with_inline_triggers {
+ my ($self, $instance, $value, $attr, $gen_code) = @_;
+ my @ga = ($instance, $value, $attr);
+ return $gen_code->(@ga) unless $self->has_trigger;
+
+ my $trigger_args = "$instance, $value, $attr";
+
+ if ('CODE' eq ref $self->trigger) {
+ return $gen_code->(@ga) . "$attr->trigger->($trigger_args);\n";
+ }
+
+ my $code = '';
+ my ($before, $around, $after) = @{$self->trigger}{qw(before around after)};
+
+ if ($before) {
+ $code .= "$attr->trigger->{before}->($trigger_args);\n";
+ }
+
+ if ($around) {
+ $code .= "$attr->trigger->{around}->(sub {\n"
+ . 'my ($instance, $value, $attr) = @_;' . "\n"
+ . $gen_code->('$instance', '$value', '$attr')
+ . "}, $trigger_args);\n";
+ }
+ else {
+ $code .= $gen_code->(@ga);
+ }
+
+ if ($after) {
+ $code .= "$attr->trigger->{after}->($trigger_args);\n";
+ }
+
+ return $code;
+}
+
+sub _with_triggers {
+ my ($self, $instance, $value, $fn) = @_;
+ my @trigger_args = ($instance, $value, $self);
+ my ($before, $around, $after);
+
+ if ($self->has_trigger) {
+ my $trig = $self->trigger;
+
+ if ('HASH' eq ref $trig) {
+ ($before, $around, $after) = @{$trig}{qw(before around after)}
+ }
+ else {
+ $after = $trig;
+ }
+ }
+
+ if ($before) {
+ $before->(@trigger_args);
+ }
+
+ if ($around) {
+ $around->($fn, @trigger_args);
+ }
+ else {
+ $fn->(@trigger_args);
+ }
+
+ if ($after) {
+ $after->(@trigger_args);
+ }
+}
+
sub initialize_instance_slot {
my ($self, $meta_instance, $instance, $params) = @_;
my $init_arg = $self->init_arg();
. $type_constraint->get_message($val);
}
- $self->set_initial_value($instance, $val);
- $meta_instance->weaken_slot_value($instance, $self->name)
- if ref $val && $self->is_weak_ref;
+ $self->_with_triggers($instance, $val, sub {
+ my ($ins, $val, $attr) = @_;
+ my $mi = Class::MOP::Class->initialize(blessed($ins))
+ ->get_meta_instance;
+ $attr->set_initial_value($ins, $val);
+ $mi->weaken_slot_value($ins, $attr->name)
+ if ref $val && $attr->is_weak_ref;
+ });
}
## Slot management
. $type_constraint->get_message($value);
}
- my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
- ->get_meta_instance;
-
- $meta_instance->set_slot_value($instance, $attr_name, $value);
-
- if (ref $value && $self->is_weak_ref) {
- $meta_instance->weaken_slot_value($instance, $attr_name);
- }
-
- if ($self->has_trigger) {
- $self->trigger->($instance, $value, $self);
- }
+ $self->_with_triggers($instance, $value, sub {
+ my ($ins, $val, $attr) = @_;
+ my $mi = Class::MOP::Class->initialize(blessed($ins))
+ ->get_meta_instance;
+ $mi->set_slot_value($ins, $attr->name, $val);
+ $mi->weaken_slot_value($ins, $attr->name)
+ if (ref $val && $attr->is_weak_ref);
+ });
}
sub get_value {
return 0;
}
-sub new_object {
- my ($class, %params) = @_;
- my $self = $class->SUPER::new_object(%params);
- foreach my $attr ($class->compute_all_applicable_attributes()) {
- # if we have a trigger, then ...
- if ($attr->can('has_trigger') && $attr->has_trigger) {
- # make sure we have an init-arg ...
- if (defined(my $init_arg = $attr->init_arg)) {
- # now make sure an init-arg was passes ...
- if (exists $params{$init_arg}) {
- # and if get here, fire the trigger
- $attr->trigger->(
- $self,
- # check if there is a coercion
- ($attr->should_coerce
- # and if so, we need to grab the
- # value that is actually been stored
- ? $attr->get_read_method_ref->($self)
- # otherwise, just get the value from
- # the constructor params
- : $params{$init_arg}),
- $attr
- );
- }
- }
- }
- }
- return $self;
-}
-
sub construct_instance {
my ($class, %params) = @_;
my $meta_instance = $class->get_meta_instance;
Override original to lock C<add_role> and memoize C<calculate_all_roles>
-=item B<new_object>
-
-We override this method to support the C<trigger> attribute option.
-
=item B<construct_instance>
This provides some Moose specific extensions to this method, you
. $self->_inline_check_coercion . "\n"
. $self->_inline_check_constraint($value_name) . "\n"
. $self->_inline_store($inv, $value_name) . "\n"
- . $self->_inline_trigger($inv, $value_name) . "\n"
. ' }' . "\n"
. $self->_inline_check_lazy . "\n"
. $self->_inline_post_body(@_) . "\n"
. $self->_inline_check_constraint($value_name)
. $self->_inline_store($inv, $value_name)
. $self->_inline_post_body(@_)
- . $self->_inline_trigger($inv, $value_name)
. ' }');
}
sub _inline_store {
my ($self, $instance, $value) = @_;
my $attr = $self->associated_attribute;
-
my $mi = $attr->associated_class->get_meta_instance;
my $slot_name = sprintf "'%s'", $attr->slots;
-
- my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";";
- $code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
- if $attr->is_weak_ref;
- return $code;
-}
-sub _inline_trigger {
- my ($self, $instance, $value) = @_;
- my $attr = $self->associated_attribute;
- return '' unless $attr->has_trigger;
- return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
+ my $gen_code = sub {
+ my ($ins_name, $val_name) = @_;
+
+ my $code = $mi->inline_set_slot_value(
+ $ins_name, $slot_name, $val_name) . ";\n";
+
+ if ($attr->is_weak_ref) {
+ $code .= $mi->inline_weaken_slot_value(
+ $ins_name, $slot_name, $val_name) . ";\n";
+ }
+
+ return $code;
+ };
+
+ if ($attr->can('_with_inline_triggers')) {
+ return $attr->_with_inline_triggers(
+ $instance, $value, '$attr', $gen_code);
+ }
+
+ return $gen_code->($instance, $value, '$attr');
}
sub _inline_get {
$self->_generate_slot_initializer($_)
} 0 .. (@{$self->attributes} - 1));
- $source .= ";\n" . $self->_generate_triggers();
$source .= ";\n" . $self->_generate_BUILDALL();
$source .= ";\n" . 'return $instance';
return join ";\n" => @BUILD_calls;
}
-sub _generate_triggers {
- my $self = shift;
- my @trigger_calls;
- foreach my $i (0 .. $#{ $self->attributes }) {
- my $attr = $self->attributes->[$i];
- if ($attr->can('has_trigger') && $attr->has_trigger) {
- if (defined(my $init_arg = $attr->init_arg)) {
- push @trigger_calls => (
- '(exists $params->{\'' . $init_arg . '\'}) && do {' . "\n "
- . '$attrs->[' . $i . ']->trigger->('
- . '$instance, '
- . $self->meta_instance->inline_get_slot_value(
- '$instance',
- ("'" . $attr->name . "'")
- )
- . ', '
- . '$attrs->[' . $i . ']'
- . ');'
- ."\n}"
- );
- }
- }
- }
- return join ";\n" => @trigger_calls;
-}
-
sub _generate_slot_initializer {
my $self = shift;
my $index = shift;
sub _generate_slot_assignment {
my ($self, $attr, $value, $index) = @_;
- my $source;
-
- if ($attr->has_initializer) {
- $source = (
- '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
- );
- }
- else {
- $source = (
- $self->meta_instance->inline_set_slot_value(
- '$instance',
- ("'" . $attr->name . "'"),
- $value
- ) . ';'
- );
- }
+ my $attr_name = "\$attrs->[$index]";
+ my $mi = $self->meta_instance;
+
+ my $gen_code = sub {
+ my ($ins_name, $val_name, $attr_name) = @_;
+ my @miargs = ($ins_name, (sprintf "'%s'", $attr->name), $val_name);
+ my $source;
+
+ if ($attr->has_initializer) {
+ $source = "$attr_name->set_initial_value($ins_name, $val_name);\n";
+ }
+ else {
+ $source = $mi->inline_set_slot_value(@miargs) . ";\n";
+ }
+
+ my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
+
+ if ($is_moose && $attr->is_weak_ref) {
+ $source .= $mi->inline_weaken_slot_value(@miargs)
+ . "if ref $val_name;\n";
+ }
+
+ return $source;
+ };
- my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
-
- if ($is_moose && $attr->is_weak_ref) {
- $source .= (
- "\n" .
- $self->meta_instance->inline_weaken_slot_value(
- '$instance',
- ("'" . $attr->name . "'")
- ) .
- ' if ref ' . $value . ';'
- );
+ if ($attr->can('_with_inline_triggers')) {
+ return $attr->_with_inline_triggers(
+ '$instance', $value, $attr_name, $gen_code);
}
- return $source;
+ return $gen_code->('$instance', $value, $attr_name);
}
sub _generate_type_coercion {
use Scalar::Util 'isweak';
-use Test::More tests => 26;
+use Test::More tests => 43;
use Test::Exception;
BEGIN {
ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
}
+# before/around/after triggers
+{
+ package Fweet;
+ use Moose;
+
+ has calls => (
+ is => 'ro',
+ isa => 'ArrayRef',
+ default => sub {[]},
+ );
+
+ sub called {
+ my ($self, $str, @args) = @_;
+ push(@{$self->calls}, $str);
+ }
+
+ has noise => (
+ is => 'rw',
+ default => 'Sartak',
+ trigger => {
+ before => sub {
+ $_[0]->called('before');
+ },
+ around => sub {
+ my ($ori, $self, $val, @whatever) = @_;
+ $self->called('around');
+ $ori->($self, $val.'-diddly', @whatever);
+ },
+ after => sub {
+ $_[0]->called('after');
+ },
+ },
+ );
+}
+
+sub fancy_trigger_tests
+{
+ my $type = shift;
+ my $blah;
+ ::lives_ok {
+ $blah = Fweet->new;
+ } "... $type constructor";
+ my $expected_calls = [qw(before around after)];
+
+ is_deeply($blah->calls, $expected_calls, "$type default triggered");
+ is($blah->noise, 'Sartak-diddly', "$type default around modified value");
+ @{$blah->calls} = ();
+
+ $blah->noise('argle-bargle');
+ is_deeply($blah->calls, $expected_calls, "$type set triggered");
+ is($blah->noise, 'argle-bargle-diddly', "$type set around modified value");
+
+ $blah = Fweet->new(noise => 'woot');
+ is_deeply($blah->calls, $expected_calls, "$type constructor triggered");
+ is($blah->noise, 'woot-diddly', "$type constructor around modified value");
+}
+
+{
+ fancy_trigger_tests('normal');
+ ::lives_ok {
+ Fweet->meta->make_immutable;
+ } '... make_immutable works';
+ fancy_trigger_tests('inline');
+}
+
# some errors
{
package Bling;
use Moose;
+
+ ::dies_ok {
+ has('bling' => (is => 'rw', trigger => {FAIL => sub {}}));
+ } '... hash specifier has to be before/around/after';
+
+ ::dies_ok {
+ has('bling' => (is => 'rw', trigger => {around => 'FAIL'}));
+ } '... hash specifier value must be CODE ref';
::dies_ok {
has('bling' => (is => 'rw', trigger => 'Fail'));
- } '... a trigger must be a CODE ref';
+ } '... a trigger must be a CODE or HASH ref';
::dies_ok {
has('bling' => (is => 'rw', trigger => []));
- } '... a trigger must be a CODE ref';
+ } '... a trigger must be a CODE or HASH ref';
}
projects / gitmo/Moose.git / commitdiff