support trigger

[gitmo/Moo.git] / lib / Method / Generate / Accessor.pm

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index b473764..04eede0 100644 (file)
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -9,36 +9,75 @@ use B 'perlstring';
 sub generate_method {
   my ($self, $into, $name, $spec, $quote_opts) = @_;
   die "Must have an is" unless my $is = $spec->{is};
-  my $name_str = perlstring $name;
+  local $self->{captures} = {};
   my $body = do {
     if ($is eq 'ro') {
-      $self->_generate_get($name_str)
+      $self->_generate_get($name)
     } elsif ($is eq 'rw') {
-      $self->_generate_getset($name_str)
+      $self->_generate_getset($name, $spec)
     } else {
       die "Unknown is ${is}";
     }
   };
   quote_sub
     "${into}::${name}" => '    '.$body."\n",
-    (ref($quote_opts) ? ({}, $quote_opts) : ())
+    $self->{captures}, $quote_opts||{}
   ;
 }
 
 sub _generate_get {
-  my ($self, $name_str) = @_;
-  "\$_[0]->{${name_str}}";
+  my ($self, $name) = @_;
+  $self->_generate_simple_get('$_[0]', $name);
+}
+
+sub generate_simple_get {
+  shift->_generate_simple_get(@_);
+}
+
+sub _generate_simple_get {
+  my ($self, $me, $name) = @_;
+  my $name_str = perlstring $name;
+  "${me}->{${name_str}}";
 }
 
 sub _generate_set {
-  my ($self, $name_str, $value) = @_;
+  my ($self, $name, $value, $spec) = @_;
+  my $simple = $self->_generate_simple_set($name, $value);
+  if (my $trigger = $spec->{trigger}) {
+    my $value = '$value';
+    my $fire = $self->_generate_trigger($name, '$_[0]', '$value', $trigger);
+    return 'do { '
+      .'my $value = '.$simple.'; '.$fire.'; '
+      .'$value }'
+    ;
+  }
+  return $simple;
+}
+
+sub generate_trigger {
+  my $self = shift;
+  local $self->{captures} = {};
+  my $code = $self->_generate_trigger(@_);
+  return ($code, $self->{captures});
+}
+
+sub _generate_trigger {
+  my ($self, $name, $obj, $value, $trigger) = @_;
+  my $cap_name = qq{\$trigger_for_${name}};
+  $self->{captures}->{$cap_name} = \$trigger;
+  "${cap_name}->(${obj}, ${value})";
+}
+
+sub _generate_simple_set {
+  my ($self, $name, $value) = @_;
+  my $name_str = perlstring $name;
   "\$_[0]->{${name_str}} = ${value}";
 }
 
 sub _generate_getset {
-  my ($self, $name_str) = @_;
-  q{(@_ > 1 ? }.$self->_generate_set($name_str, q{$_[1]})
-    .' : '.$self->_generate_get($name_str).')';
+  my ($self, $name, $spec) = @_;
+  q{(@_ > 1 ? }.$self->_generate_set($name, q{$_[1]}, $spec)
+    .' : '.$self->_generate_get($name).')';
 }
 
 1;