From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 7 Nov 2010 07:07:15 +0000 (+0000)
Subject: inline quoted trigger
X-Git-Tag: 0.009001~62
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=625d6219e7b1d3dca220a793e672720b490e094f;p=gitmo%2FMoo.git

inline quoted trigger
---

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 04eede0..3e78d79 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -63,9 +63,14 @@ sub generate_trigger {
 
 sub _generate_trigger {
   my ($self, $name, $obj, $value, $trigger) = @_;
+  if (my $quoted = quoted_from_sub($trigger)) {
+    die "Captures? ARGH!" if $quoted->[2];
+    my $code = $quoted->[1];
+    return 'do { local @_ = ('.join(', ', $obj, $value).'); '.$code.' }';
+  }
   my $cap_name = qq{\$trigger_for_${name}};
   $self->{captures}->{$cap_name} = \$trigger;
-  "${cap_name}->(${obj}, ${value})";
+  return "${cap_name}->(${obj}, ${value})";
 }
 
 sub _generate_simple_set {
diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm
index 0fb6884..c93eefa 100644
--- a/lib/Sub/Quote.pm
+++ b/lib/Sub/Quote.pm
@@ -8,7 +8,7 @@ use Sub::Defer;
 use B 'perlstring';
 use base qw(Exporter);
 
-our @EXPORT = qw(quote_sub unquote_sub);
+our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub);
 
 our %QUOTE_OUTSTANDING;
 
@@ -86,6 +86,7 @@ sub quote_sub {
       ? pop
       : {};
   my $captures = pop if ref($_[-1]) eq 'HASH';
+  undef($captures) if $captures && !keys %$captures;
   my $code = pop;
   my $name = $_[0];
   my $outstanding;
diff --git a/t/accessor-trigger.t b/t/accessor-trigger.t
index 0af7402..c19edb5 100644
--- a/t/accessor-trigger.t
+++ b/t/accessor-trigger.t
@@ -1,32 +1,51 @@
 use strictures 1;
 use Test::More;
 
-my @one_tr;
+our @tr;
 
-{
-  package Foo;
+sub run_for {
+  my $class = shift;
 
-  use Class::Tiny;
+  @tr = ();
 
-  has one => (is => 'rw', trigger => sub { push @one_tr, $_[1] });
-}
+  my $obj = $class->new;
+
+  ok(!@tr, "${class}: trigger not fired with no value");
 
-my $foo = Foo->new;
+  $obj = $class->new(one => 1);
 
-ok(!@one_tr, "trigger not fired with no value");
+  is_deeply(\@tr, [ 1 ], "${class}: trigger fired on new");
 
-$foo = Foo->new(one => 1);
+  my $res = $obj->one(2);
 
-is_deeply(\@one_tr, [ 1 ], "trigger fired on new");
+  is_deeply(\@tr, [ 1, 2 ], "${class}: trigger fired on set");
 
-my $res = $foo->one(2);
+  is($res, 2, "${class}: return from set ok");
 
-is_deeply(\@one_tr, [ 1, 2 ], "trigger fired on set");
+  is($obj->one, 2, "${class}: return from accessor ok");
 
-is($res, 2, "return from set ok");
+  is_deeply(\@tr, [ 1, 2 ], "${class}: trigger not fired for accessor as get");
+}
 
-is($foo->one, 2, "return from accessor ok");
+{
+  package Foo;
+
+  use Class::Tiny;
+
+  has one => (is => 'rw', trigger => sub { push @::tr, $_[1] });
+}
+
+run_for 'Foo';
+
+{
+  package Bar;
+
+  use Sub::Quote;
+  use Class::Tiny;
+
+  has one => (is => 'rw', trigger => quote_sub q{ push @::tr, $_[1] });
+}
 
-is_deeply(\@one_tr, [ 1, 2 ], "trigger not fired for accessor as get");
+run_for 'Bar';
 
 done_testing;