From: Stevan Little Date: Tue, 22 Jul 2008 15:43:50 +0000 (+0000) Subject: rolling back X-Git-Tag: 0_55~43 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=65e14c863ae29b3fa9a54a84269984f5dad6a400;p=gitmo%2FMoose.git rolling back --- diff --git a/Changes b/Changes index dd1d7e7..0d8b305 100644 --- a/Changes +++ b/Changes @@ -7,10 +7,6 @@ Revision history for Perl extension Moose 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) diff --git a/lib/Moose.pm b/lib/Moose.pm index a74108d..ecc8801 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -454,16 +454,13 @@ If an attribute is marked as lazy it B have a default supplied. This tells the accessor whether to automatically dereference the value returned. This is only legal if your C option is either C or C. -=item I $code or $hash> - -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, the -updated value and the attribute meta-object (this is for more advanced -fiddling and can typically be ignored). You B 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 $code> + +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, the +updated value and the attribute meta-object (this is for more advanced fiddling +and can typically be ignored). You B have a trigger on a read-only +attribute. =item I ARRAY | HASH | REGEXP | ROLE | CODE> diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 21765b3..d631120 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -312,21 +312,8 @@ sub _process_options { } 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}) { @@ -364,73 +351,6 @@ sub _process_options { } -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(); @@ -480,14 +400,9 @@ sub initialize_instance_slot { . $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 @@ -555,14 +470,18 @@ sub set_value { . $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 { @@ -955,11 +874,6 @@ value of an attribute is assigned. The CODE ref will get two values, the invocant and the new value. This can be used to handle I 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 This is a string which contains the documentation for this attribute. diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index e24f08e..92a84b1 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -120,6 +120,36 @@ sub excludes_role { 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; @@ -440,6 +470,10 @@ and altering the Constructor metaclass. Override original to lock C and memoize C +=item B + +We override this method to support the C attribute option. + =item B This provides some Moose specific extensions to this method, you diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm index 818d377..e96b83a 100644 --- a/lib/Moose/Meta/Method/Accessor.pm +++ b/lib/Moose/Meta/Method/Accessor.pm @@ -51,6 +51,7 @@ sub generate_accessor_method_inline { . $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" @@ -74,6 +75,7 @@ sub generate_writer_method_inline { . $self->_inline_check_constraint($value_name) . $self->_inline_store($inv, $value_name) . $self->_inline_post_body(@_) + . $self->_inline_trigger($inv, $value_name) . ' }'); } @@ -213,29 +215,21 @@ sub _inline_init_slot { 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 { diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm index 5803fdb..6dc6f04 100644 --- a/lib/Moose/Meta/Method/Constructor.pm +++ b/lib/Moose/Meta/Method/Constructor.pm @@ -83,6 +83,7 @@ sub initialize_body { $self->_generate_slot_initializer($_) } 0 .. (@{$self->attributes} - 1)); + $source .= ";\n" . $self->_generate_triggers(); $source .= ";\n" . $self->_generate_BUILDALL(); $source .= ";\n" . 'return $instance'; @@ -146,6 +147,32 @@ sub _generate_BUILDALL { 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; @@ -242,37 +269,37 @@ sub _generate_slot_initializer { 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 { diff --git a/t/020_attributes/004_attribute_triggers.t b/t/020_attributes/004_attribute_triggers.t index e4088a2..b5cf34e 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 => 43; +use Test::More tests => 26; use Test::Exception; BEGIN { @@ -102,92 +102,19 @@ 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'; } diff --git a/t/100_bugs/018_immutable_metaclass_does_role.t b/t/100_bugs/018_immutable_metaclass_does_role.t index 874fc30..280af26 100644 --- a/t/100_bugs/018_immutable_metaclass_does_role.t +++ b/t/100_bugs/018_immutable_metaclass_does_role.t @@ -1,40 +1,64 @@ +#!/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' );