From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 7 Nov 2010 06:58:11 +0000 (+0000)
Subject: support trigger
X-Git-Tag: 0.009001~63
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a16d301ee1659572170ed6baebb3f5e2451b35f5;p=gitmo%2FMoo.git

support trigger
---

diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm
index 91d6650..4484eca 100644
--- a/lib/Class/Tiny.pm
+++ b/lib/Class/Tiny.pm
@@ -7,6 +7,7 @@ our %MAKERS;
 
 sub import {
   my $target = caller;
+  my $class = shift;
   strictures->import;
   *{_getglob("${target}::extends")} = sub {
     *{_getglob("${target}::ISA")} = \@_;
@@ -16,27 +17,15 @@ sub import {
     die "Only one role supported at a time by with" if @_ > 1;
     Role::Tiny->apply_role_to_package($_[0], $target);
   };
+  $MAKERS{$target} = {};
   *{_getglob("${target}::has")} = sub {
     my ($name, %spec) = @_;
     ($MAKERS{$target}{accessor} ||= do {
       require Method::Generate::Accessor;
       Method::Generate::Accessor->new
     })->generate_method($target, $name, \%spec);
-    ($MAKERS{$target}{constructor} ||= do {
-      require Method::Generate::Constructor;
-      Method::Generate::Constructor
-        ->new(package => $target)
-        ->install_delayed
-        ->register_attribute_specs(do {
-          my @spec;
-          if (my $super = do { no strict 'refs'; ${"${target}::ISA"}[0] }) {
-            if (my $con = $MAKERS{$super}{constructor}) {
-              @spec = %{$con->all_attribute_specs};
-            }
-          }
-          @spec;
-        });
-    })->register_attribute_specs($name, \%spec);
+    $class->_constructor_maker_for($target)
+          ->register_attribute_specs($name, \%spec);
   };
   foreach my $type (qw(before after around)) {
     *{_getglob "${target}::${type}"} = sub {
@@ -51,4 +40,30 @@ sub import {
   }
 }
 
+sub _constructor_maker_for {
+  my ($class, $target) = @_;
+  return unless $MAKERS{$target};
+  $MAKERS{$target}{constructor} ||= do {
+    require Method::Generate::Constructor;
+    Method::Generate::Constructor
+      ->new(
+        package => $target,
+        accessor_generator => do {
+          require Method::Generate::Accessor;
+          Method::Generate::Accessor->new;
+        }
+      )
+      ->install_delayed
+      ->register_attribute_specs(do {
+        my @spec;
+        if (my $super = do { no strict 'refs'; ${"${target}::ISA"}[0] }) {
+          if (my $con = $MAKERS{$super}{constructor}) {
+            @spec = %{$con->all_attribute_specs};
+          }
+        }
+        @spec;
+      });
+  }
+}
+
 1;
diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index b473764..04eede0 100644
--- 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;
diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm
index 41af94e..6d45aee 100644
--- a/lib/Method/Generate/Constructor.pm
+++ b/lib/Method/Generate/Constructor.pm
@@ -4,6 +4,7 @@ use strictures 1;
 use Sub::Quote;
 use base qw(Class::Tiny::Object);
 use Sub::Defer;
+use B 'perlstring';
 
 sub register_attribute_specs {
   my ($self, %spec) = @_;
@@ -15,6 +16,10 @@ sub all_attribute_specs {
   $_[0]->{attribute_specs}
 }
 
+sub accessor_generator {
+  $_[0]->{accessor_generator}
+}
+
 sub install_delayed {
   my ($self) = @_;
   my $package = $self->{package};
@@ -31,15 +36,17 @@ sub generate_method {
   foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) {
     $spec->{$no_init}{init_arg} = $no_init;
   }
+  local $self->{captures} = {};
   my $body = '    my $class = shift;'."\n";
   $body .= $self->_generate_args;
   $body .= $self->_check_required($spec);
   $body .= '    my $new = bless({}, $class);'."\n";
   $body .= $self->_assign_new($spec);
+  $body .= $self->_fire_triggers($spec);
   $body .= '    return $new;'."\n";
   quote_sub
     "${into}::${name}" => $body,
-    (ref($quote_opts) ? ({}, $quote_opts) : ())
+    $self->{captures}, $quote_opts||{}
   ;
 }
 
@@ -77,4 +84,24 @@ sub _check_required {
     ."    }\n";
 }
 
+sub _fire_triggers {
+  my ($self, $spec) = @_;
+  my @fire = map {
+    [ $_, $spec->{$_}{init_arg}, $spec->{$_}{trigger} ]
+  } grep { $spec->{$_}{init_arg} && $spec->{$_}{trigger} } keys %$spec;
+  my $acc = $self->accessor_generator;
+  my $captures = $self->{captures};
+  my $fire = '';
+  foreach my $name (keys %$spec) {
+    my ($init, $trigger) = @{$spec->{$name}}{qw(init_arg trigger)};
+    next unless $init && $trigger;
+    my ($code, $add_captures) = $acc->generate_trigger(
+      $name, '$new', $acc->generate_simple_get('$new', $name), $trigger
+    );
+    @{$captures}{keys %$add_captures} = values %$add_captures;
+    $fire .= "    ${code} if exists \$args->{${\perlstring $init}};\n";
+  }
+  return $fire;
+}
+
 1;
diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm
index b830f64..337c25d 100644
--- a/lib/Role/Tiny.pm
+++ b/lib/Role/Tiny.pm
@@ -97,22 +97,10 @@ sub apply_role_to_package {
     if ($INFO{$to}) {
       @{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info;
     } else {
-      my $con = $Class::Tiny::MAKERS{$to}{constructor} ||= do {
-        require Method::Generate::Constructor;
-        Method::Generate::Constructor
-          ->new(package => $to)
-          ->install_delayed
-          ->register_attribute_specs(do {
-            my @spec;
-            if (my $super = do { no strict 'refs'; ${"${to}::ISA"}[0] }) {
-              if (my $con = $Class::Tiny::MAKERS{$super}{constructor}) {
-                @spec = %{$con->all_attribute_specs};
-              }
-            }
-            @spec;
-          });
-      };
-      $con->register_attribute_specs(%$attr_info);
+      # only fiddle with the constructor if the target is a Class::Tiny class
+      if (my $con = Class::Tiny->_constructor_maker_for($to)) {
+        $con->register_attribute_specs(%$attr_info);
+      }
     }
   }
 
diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm
index 86526ab..0fb6884 100644
--- a/lib/Sub/Quote.pm
+++ b/lib/Sub/Quote.pm
@@ -54,21 +54,23 @@ sub _unquote_all_outstanding {
     $make_sub .= "}\n";
     $assembled_code .= $make_sub;
   }
+  my $debug_code = $assembled_code;
   if (@localize_these) {
-    $ENV{SUB_QUOTE_DEBUG} && warn
+    $debug_code =
       "# localizing: ".join(', ', @localize_these)."\n"
       .$assembled_code;
     $assembled_code = join("\n",
       (map { "local *${_};" } @localize_these),
-      'eval '.perlstring $assembled_code
+      'eval '.perlstring($assembled_code).'; die $@ if $@;'
     );
   } else {
     $ENV{SUB_QUOTE_DEBUG} && warn $assembled_code;
   }
-  _clean_eval $assembled_code, \@assembled_captures;
-  if ($@) {
-    die "Eval went very, very wrong:\n\n${assembled_code}\n\n$@";
+  $assembled_code .= "\n1;";
+  unless (_clean_eval $assembled_code, \@assembled_captures) {
+    die "Eval went very, very wrong:\n\n${debug_code}\n\n$@";
   }
+  $ENV{SUB_QUOTE_DEBUG} && warn $debug_code;
   %QUOTE_OUTSTANDING = ();
 }
 
diff --git a/t/accessor-trigger.t b/t/accessor-trigger.t
new file mode 100644
index 0000000..0af7402
--- /dev/null
+++ b/t/accessor-trigger.t
@@ -0,0 +1,32 @@
+use strictures 1;
+use Test::More;
+
+my @one_tr;
+
+{
+  package Foo;
+
+  use Class::Tiny;
+
+  has one => (is => 'rw', trigger => sub { push @one_tr, $_[1] });
+}
+
+my $foo = Foo->new;
+
+ok(!@one_tr, "trigger not fired with no value");
+
+$foo = Foo->new(one => 1);
+
+is_deeply(\@one_tr, [ 1 ], "trigger fired on new");
+
+my $res = $foo->one(2);
+
+is_deeply(\@one_tr, [ 1, 2 ], "trigger fired on set");
+
+is($res, 2, "return from set ok");
+
+is($foo->one, 2, "return from accessor ok");
+
+is_deeply(\@one_tr, [ 1, 2 ], "trigger not fired for accessor as get");
+
+done_testing;