From: Stevan Little Date: Sun, 16 Apr 2006 03:00:35 +0000 (+0000) Subject: triggers X-Git-Tag: 0_05~29 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8c9d74e741308a5ff5731db8dff81ea464058e6d;p=gitmo%2FMoose.git triggers --- diff --git a/Changes b/Changes index c20448b..411f6a5 100644 --- a/Changes +++ b/Changes @@ -17,6 +17,15 @@ Revision history for Perl extension Moose it relys on the one in Moose::Object - added roles attribute and some methods to support roles consuming roles + + * Moose::Meta::Attribute + - added support for triggers on attributes + - added tests for this + + * Moose::Meta::Class + - added support for attribute triggers in the + object construction + - added tests for this * Moose - Moose no longer creates a subtype for your class @@ -26,7 +35,12 @@ Revision history for Perl extension Moose * Moose::Util::TypeConstraints - fixed bug where incorrect subtype conflicts were being reported - - added tests for this + - added test for this + + * Moose::Object + - this class can now be extended with 'use base' if + you need it, it properly loads the metaclass class now + - added test for this 0.03_02 Wed. April 12, 2006 * Moose diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index a958a82..41c1de4 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util 'blessed', 'weaken', 'reftype'; use Carp 'confess'; -our $VERSION = '0.03'; +our $VERSION = '0.04'; use Moose::Util::TypeConstraints '-no-export'; @@ -21,6 +21,10 @@ __PACKAGE__->meta->add_attribute('type_constraint' => ( reader => 'type_constraint', predicate => 'has_type_constraint', )); +__PACKAGE__->meta->add_attribute('trigger' => ( + reader => 'trigger', + predicate => 'has_trigger', +)); sub new { my ($class, $name, %options) = @_; @@ -28,9 +32,14 @@ sub new { if (exists $options{is}) { if ($options{is} eq 'ro') { $options{reader} = $name; + (!exists $options{trigger}) + || confess "Cannot have a trigger on a read-only attribute"; } elsif ($options{is} eq 'rw') { $options{accessor} = $name; + (reftype($options{trigger}) eq 'CODE') + || confess "A trigger must be a CODE reference" + if exists $options{trigger}; } } @@ -90,6 +99,9 @@ sub generate_accessor_method { . ($self->is_weak_ref ? 'weaken($_[0]->{$attr_name});' : '') + . ($self->has_trigger ? + '$self->trigger->($_[0], ' . $value_name . ');' + : '') . ' }' . ($self->is_lazy ? '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)' @@ -121,6 +133,9 @@ sub generate_writer_method { . ($self->is_weak_ref ? 'weaken($_[0]->{$attr_name});' : '') + . ($self->has_trigger ? + '$self->trigger->($_[0], ' . $value_name . ');' + : '') . ' }'; my $sub = eval $code; confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@; @@ -217,6 +232,10 @@ NOTE: lazy attributes, B have a C field set. Returns true of this meta-attribute should perform type coercion. +=item B + +=item B + =back =head1 BUGS diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 26df000..810b608 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -35,6 +35,16 @@ sub does_role { return 0; } +sub new_object { + my ($class, %params) = @_; + my $self = $class->SUPER::new_object(%params); + foreach my $attr ($class->compute_all_applicable_attributes()) { + next unless $params{$attr->name} && $attr->has_trigger; + $attr->trigger->($self, $params{$attr->name}); + } + return $self; +} + sub construct_instance { my ($class, %params) = @_; my $instance = $params{'__INSTANCE__'} || {}; @@ -174,6 +184,8 @@ to the L documentation. =over 4 +=item B + =item B This provides some Moose specific extensions to this method, you diff --git a/t/033_attribute_triggers.t b/t/033_attribute_triggers.t new file mode 100644 index 0000000..66b0861 --- /dev/null +++ b/t/033_attribute_triggers.t @@ -0,0 +1,110 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Scalar::Util 'isweak'; + +use Test::More tests => 24; +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +{ + package Foo; + use strict; + use warnings; + use Moose; + + has 'bar' => (is => 'rw', + isa => 'Bar', + trigger => sub { + my ($self, $bar) = @_; + $bar->foo($self) if defined $bar; + }); + + has 'baz' => (writer => 'set_baz', + reader => 'get_baz', + isa => 'Baz', + trigger => sub { + my ($self, $baz) = @_; + $baz->foo($self); + }); + + + package Bar; + use strict; + use warnings; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); + + package Baz; + use strict; + use warnings; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); +} + +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + + my $baz = Baz->new; + isa_ok($baz, 'Baz'); + + lives_ok { + $foo->bar($bar); + } '... did not die setting bar'; + + is($foo->bar, $bar, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); + + lives_ok { + $foo->bar(undef); + } '... did not die un-setting bar'; + + is($foo->bar, undef, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + # test the writer + + lives_ok { + $foo->set_baz($baz); + } '... did not die setting baz'; + + is($foo->get_baz, $baz, '... set the value foo.baz correctly'); + is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); + + ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); +} + +{ + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + + my $baz = Baz->new; + isa_ok($baz, 'Baz'); + + my $foo = Foo->new(bar => $bar, baz => $baz); + isa_ok($foo, 'Foo'); + + is($foo->bar, $bar, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); + + is($foo->get_baz, $baz, '... set the value foo.baz correctly'); + is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); + + ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); +} +