created so that the process can be more easily
overridden by subclasses (stevan)
- - implemented Sartak's idea for
- before/after/around triggers, should be
- backcompat with plain CODE refs. (frodwith)
-
* Moose::Meta::TypeConstraint
- fixing what is passed into a ->message with
the type constraints (RT #37569)
This tells the accessor whether to automatically dereference the value returned.
This is only legal if your C<isa> option is either C<ArrayRef> or C<HashRef>.
-=item I<trigger =E<gt> $code or $hash>
-
-The I<trigger> 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, the
-updated value and the attribute meta-object (this is for more advanced
-fiddling and can typically be ignored). You B<cannot> have a trigger on a
-read-only attribute. It can optionally be a hashref of before/after/around to
-CODE refs, in which case after/before behave as in the plain CODE ref case,
-and around first gets a CODE ref which takes the rest of the args and sets the
-value.
+=item I<trigger =E<gt> $code>
+
+The I<trigger> 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, the
+updated value and the attribute meta-object (this is for more advanced fiddling
+and can typically be ignored). You B<cannot> have a trigger on a read-only
+attribute.
=item I<handles =E<gt> ARRAY | HASH | REGEXP | ROLE | CODE>
}
if (exists $options->{trigger}) {
- 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)";
- }
+ ('CODE' eq ref $options->{trigger})
+ || confess "Trigger must be a CODE 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->_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;
- });
+ $self->set_initial_value($instance, $val);
+ $meta_instance->weaken_slot_value($instance, $self->name)
+ if ref $val && $self->is_weak_ref;
}
## Slot management
. $type_constraint->get_message($value);
}
- $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);
- });
+ 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);
+ }
}
sub get_value {
the invocant and the new value. This can be used to handle I<basic>
bi-directional relations.
-This can also be a HASH of CODE refs for before/around/after, much
-in the same vein as method modifiers. After and before work just
-like the plain CODE ref case. Around first gets a CODE ref that
-expects the rest of the args and will assign the value.
-
=item B<documentation>
This is a string which contains the documentation for this attribute.
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;
+}
- 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_trigger {
+ my ($self, $instance, $value) = @_;
+ my $attr = $self->associated_attribute;
+ return '' unless $attr->has_trigger;
+ return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
}
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 $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 $source;
- if ($attr->can('_with_inline_triggers')) {
- return $attr->_with_inline_triggers(
- '$instance', $value, $attr_name, $gen_code);
+ 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 $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 . ';'
+ );
}
- return $gen_code->('$instance', $value, $attr_name);
+ return $source;
}
sub _generate_type_coercion {
use Scalar::Util 'isweak';
-use Test::More tests => 43;
+use Test::More tests => 26;
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 or HASH ref';
+ } '... a trigger must be a CODE ref';
::dies_ok {
has('bling' => (is => 'rw', trigger => []));
- } '... a trigger must be a CODE or HASH ref';
+ } '... a trigger must be a CODE ref';
}
+#!/usr/bin/perl
-{
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+}
+
+BEGIN {
package MyRole;
use Moose::Role;
- BEGIN {
- requires 'foo';
- }
- no Moose::Role;
-}
-{
+
+ requires 'foo';
+
package MyMetaclass;
- use Moose;
- BEGIN {
- sub foo { 'i am foo' }
- extends 'Moose::Meta::Class';
- with 'MyRole';
- }
- no Moose;
+ use Moose qw(extends with);
+ extends 'Moose::Meta::Class';
+ with 'MyRole';
+
+ sub foo { 'i am foo' }
}
{
package MyClass;
- use metaclass 'MyMetaclass';
+ use metaclass ('MyMetaclass');
use Moose;
- no Moose;
}
-use Test::More tests => 5;
+my $mc = MyMetaclass->initialize('MyClass');
+isa_ok($mc, 'MyMetaclass');
+
+ok($mc->meta->does_role('MyRole'), '... the metaclass does the role');
+
+is(MyClass->meta, $mc, '... these metas are the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
my $a = MyClass->new;
ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
-# now try combinations of having the class/metaclass made immutable
-# and run the same test
+diag join ", " => map { $_->name } @{$mc->meta->roles};
+diag join ", " => map { $_->name } $mc->meta->calculate_all_roles;
+
+lives_ok {
+ MyClass->meta->make_immutable;
+} '... make MyClass immutable okay';
+
+diag join ", " => map { $_->name } @{$mc->meta->roles};
+diag join ", " => map { $_->name } $mc->meta->calculate_all_roles;
+
+is(MyClass->meta, $mc, '... these metas are still the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
-MyClass->meta->make_immutable;
ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+
+=pod
MyClass->meta->make_mutable;
ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
projects / gitmo/Moose.git / commitdiff