X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Antlers.git;a=blobdiff_plain;f=lib%2FMooseX%2FAntlers%2FEvalTracker.pm;fp=lib%2FMooseX%2FAntlers%2FEvalTracker.pm;h=e2cc227d978faf3574ed7fe3365d09ea113cf935;hp=68a85cc3d12bf3b51a05145c3b5ee679f788b7f5;hb=e4612bc2e2ae3f9ec37305ee16fa35079cde7dfb;hpb=699c71b861cf76e5881b373deb1e5fe3eebc6e9b

diff --git a/lib/MooseX/Antlers/EvalTracker.pm b/lib/MooseX/Antlers/EvalTracker.pm
index 68a85cc..e2cc227 100644
--- a/lib/MooseX/Antlers/EvalTracker.pm
+++ b/lib/MooseX/Antlers/EvalTracker.pm
@@ -3,12 +3,14 @@ package MooseX::Antlers::EvalTracker;
 use Moose;
 use Scalar::Util qw(weaken refaddr);
 use PadWalker qw(closed_over);
+use Sub::Identify qw(sub_fullname);
+use B qw(perlstring);
 use namespace::clean -except => 'meta';
 
 has '_original_eval_closure' => (is => 'ro', lazy_build => 1);
 has '_our_eval_closure' => (is => 'ro', lazy_build => 1);
 
-has 'recorded_coderefs' => (is => 'ro', default => sub { {} });
+has 'recorded_coderefs' => (is => 'ro', default => sub { [] });
 
 has 'is_enabled' => (is => 'rw');
 
@@ -23,6 +25,8 @@ sub _build__our_eval_closure {
   # _eval_closure returns a CODE ref and we want that too
   sub {
     my $self = shift;
+    # ... screwed over here by $attr->default(...) and ->trigger(...)
+    # in the bloody inlined subs. XXX slap stevan, fix Moose
     # until we stop passing these let's make anything that uses it
     # crash out so at least we don't break anything
     #delete @{$_[0]}{qw($meta $attr)};
@@ -59,11 +63,40 @@ sub _install {
 
 sub _eval_closure_called_for {
   my ($self, $cr, $captures, $body) = @_;
-  use Data::Dumper; $Data::Dumper::Indent = 1;
   my %captured = %{closed_over $cr};
   delete @{$captures}{grep !exists($captured{$_}), keys %$captures};
-  warn Dumper($captures);
-  warn Dumper($body);
+  push(@{$self->recorded_coderefs}, [ $cr, $captures, $body ]);
+  #use Data::Dumper; $Data::Dumper::Indent = 1;
+  #warn Dumper($captures);
+  #warn Dumper($body);
+}
+
+sub _generate_coderef_constructor {
+  my ($self, $entry) = @_;
+  my ($cr, $captures, $body) = @{$entry};
+  my $name = sub_fullname($cr);
+  join(
+    "\n",
+    "sub {",
+    '  my $__captures = shift;',
+    $self->_generate_capture_constructor($captures),
+    'use Sub::Name ();',
+    'return *'.$name.' = Sub::Name::subname '.perlstring($name).' =>',
+    "${body};",
+    '}',
+  );
+}
+
+sub _generate_capture_constructor {
+  my ($self, $captures) = @_;
+  join(
+    "\n",
+    (map {
+      /^([\@\%\$])/ or die "capture key should start with \@, \% or \$: $_";
+      q!  my !.$_.q! = !.$1.q!{$__captures->{'!.$_.q!'}};!;
+    } keys %$captures),
+    '' # trailing \n
+  );
 }
 
 sub DEMOLISH { shift->disable }