From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 7 Nov 2010 07:37:36 +0000 (+0000)
Subject: handle trigger with captures
X-Git-Tag: 0.009001~61
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8c6626cf0cfd1a6a9c39b5cf9db2b74d96afb0f3;p=gitmo%2FMoo.git

handle trigger with captures
---

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 3e78d79..5623366 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -64,8 +64,15 @@ 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];
+    my $at_ = 'local @_ = ('.join(', ', $obj, $value).');';
+    if (my $captures = $quoted->[2]) {
+      my $cap_name = qq{\$trigger_captures_for_${name}};
+      $self->{captures}->{$cap_name} = \$captures;
+      return "do {\n".'      '.$at_."\n"
+	.Sub::Quote::capture_unroll($cap_name, $captures, 6)
+	."     ${code}\n    }";
+    }
     return 'do { local @_ = ('.join(', ', $obj, $value).'); '.$code.' }';
   }
   my $cap_name = qq{\$trigger_for_${name}};
diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm
index c93eefa..3bb4be3 100644
--- a/lib/Sub/Quote.pm
+++ b/lib/Sub/Quote.pm
@@ -14,6 +14,18 @@ our %QUOTE_OUTSTANDING;
 
 our %QUOTED;
 
+sub capture_unroll {
+  my ($from, $captures, $indent) = @_;
+  join(
+    '',
+    map {
+      /^([\@\%\$])/
+	or die "capture key should start with \@, \% or \$: $_";
+      (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n};
+    } keys %$captures
+  );
+}
+
 sub _unquote_all_outstanding {
   return unless %QUOTE_OUTSTANDING;
   my ($assembled_code, @assembled_captures, @localize_these) = '';
@@ -26,14 +38,7 @@ sub _unquote_all_outstanding {
 
     if (keys %$captures) {
       my $ass_cap_count = @assembled_captures;
-      $make_sub .= join(
-        "\n",
-        map {
-          /^([\@\%\$])/
-            or die "capture key should start with \@, \% or \$: $_";
-          qq{  my ${_} = ${1}{\$_[1][${ass_cap_count}]{${\perlstring $_}}};\n};
-        } keys %$captures
-      );
+      $make_sub .= capture_unroll("\$_[1][${ass_cap_count}]", $captures, 2);
       push @assembled_captures, $captures;
     }
 
diff --git a/t/accessor-trigger.t b/t/accessor-trigger.t
index c19edb5..dcda49f 100644
--- a/t/accessor-trigger.t
+++ b/t/accessor-trigger.t
@@ -48,4 +48,18 @@ run_for 'Foo';
 
 run_for 'Bar';
 
+{
+  package Baz;
+
+  use Sub::Quote;
+  use Class::Tiny;
+
+  has one => (
+    is => 'rw',
+    trigger => quote_sub(q{ push @{$tr}, $_[1] }, { '$tr' => \\@::tr })
+  );
+}
+
+run_for 'Baz';
+
 done_testing;