From: Paul Driver <frodwith@gmail.com>
Date: Fri, 18 Jul 2008 20:09:41 +0000 (+0000)
Subject: Added support for fancy triggers, and a test.
X-Git-Tag: 0_55~46^2~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c26a8868652403a286e6da8936d5941783d5bfce;p=gitmo%2FMoose.git

Added support for fancy triggers, and a test.
---

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index d631120..1ad7550 100644
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -312,8 +312,21 @@ sub _process_options {
     }
 
     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}) {
@@ -351,6 +364,73 @@ 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();
@@ -400,9 +480,14 @@ sub initialize_instance_slot {
                      . $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
@@ -470,18 +555,14 @@ sub set_value {
                      . $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 {
diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 92a84b1..e24f08e 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -120,36 +120,6 @@ 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;
@@ -470,10 +440,6 @@ and altering the Constructor metaclass.
 
 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
diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm
index e96b83a..818d377 100644
--- a/lib/Moose/Meta/Method/Accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor.pm
@@ -51,7 +51,6 @@ 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"
@@ -75,7 +74,6 @@ 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)
     . ' }');
 }
 
@@ -215,21 +213,29 @@ 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;
-}
 
-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 {
diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index 6dc6f04..5803fdb 100644
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -83,7 +83,6 @@ 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';
@@ -147,32 +146,6 @@ 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;
@@ -269,37 +242,37 @@ sub _generate_slot_initializer {
 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 {
diff --git a/t/020_attributes/004_attribute_triggers.t b/t/020_attributes/004_attribute_triggers.t
index b5cf34e..e4088a2 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 => 26;
+use Test::More tests => 43;
 use Test::Exception;
 
 BEGIN {
@@ -102,19 +102,92 @@ 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';    
 }