triggers

diff --git a/Changes b/Changes
index c20448b..411f6a5 100644 (file)
--- 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 (file)
--- 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<must> have a C<default> field set.
 
 Returns true of this meta-attribute should perform type coercion.
 
+=item B<has_trigger>
+
+=item B<trigger>
+
 =back
 
 =head1 BUGS

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 26df000..810b608 100644 (file)
--- 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<Class::MOP::Class> documentation.
 
 =over 4
 
+=item B<new_object>
+
 =item B<construct_instance>
 
 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 (file)
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');
+}
+