From: Matt S Trout <mst@shadowcat.co.uk>
Date: Mon, 22 Jun 2009 01:22:59 +0000 (-0400)
Subject: serialising roughly the right things in roughly the right order
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e4612bc2e2ae3f9ec37305ee16fa35079cde7dfb;p=gitmo%2FMooseX-Antlers.git

serialising roughly the right things in roughly the right order
---

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 }
diff --git a/t/track_eval.t b/t/track_eval.t
index d81fb35..20f34ef 100644
--- a/t/track_eval.t
+++ b/t/track_eval.t
@@ -1,6 +1,29 @@
 use strict;
 use warnings;
 use aliased 'MooseX::Antlers::EvalTracker';
+use aliased 'MooseX::Antlers::RefTracker';
+use aliased 'MooseX::Antlers::RefFilter';
+use Moose ();
+use B qw(perlstring);
+use Scalar::Util qw(refaddr);
+
+my @trap;
+
+{
+  my $orig = Moose::Meta::Class->can('add_attribute');
+  no warnings 'redefine';
+  *Moose::Meta::Class::add_attribute = sub {
+    my ($self, $name) = @_;
+    my $root_name = 
+      '$add_attribute{'.perlstring($self->name).'}'
+                   .'{'.perlstring($name).'}';
+    my $tracker = RefTracker->new({ root_name => $root_name });
+    $tracker->visit(\@_);
+    my $refs = $tracker->traced_ref_map;
+    push(@trap, [ $root_name, $name, $refs ]);
+    return $orig->(@_);
+  };
+}
 
 my $et = EvalTracker->new;
 
@@ -13,3 +36,48 @@ $et->enable;
 
   has 'test' => (is => 'rw', trigger => sub { warn "trigger!\n" });
 }
+
+use Data::Dumper; $Data::Dumper::Indent = 1;
+
+my $attr_root = '$meta->{attributes}{'.perlstring($trap[0][1]).'}';
+
+my $filter_attr = RefFilter->new({
+  external_mappings => $trap[0][2],
+  root_name => $attr_root,
+});
+
+$trap[0][2]{refaddr(Foo->meta)} = '$meta';
+my $cr = $et->recorded_coderefs->[0][0];
+$trap[0][2]{refaddr($cr)} = '$coderefs[0]';
+
+my $attr_object = Foo->meta->{attributes}{$trap[0][1]};
+
+my $record = $filter_attr->visit($attr_object);
+
+my $tracker = RefTracker->new({
+  root_name => $attr_root,
+});
+
+$tracker->visit($record);
+
+my $filter_captures = RefFilter->new({
+  external_mappings => {
+    %{$tracker->traced_ref_map}, %{$trap[0][2]},
+    refaddr($attr_object) => $attr_root,
+  },
+  root_name => '$captures',
+});
+
+my $captures_record = $filter_captures->visit($et->recorded_coderefs->[0][1]);
+
+warn Data::Dumper->Dump([$record],[$attr_root]);
+
+warn 'my '.Data::Dumper->Dump([$captures_record],['$captures']);
+
+warn $filter_captures->fixup_code;
+
+warn 'my @coderefs = ('."\n".$et->_generate_coderef_constructor($et->recorded_coderefs->[0])."->(\$captures)\n);\n";
+
+warn $filter_attr->fixup_code;
+
+#warn %{$trap[0]};