From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 21 Jun 2009 19:12:24 +0000 (-0400)
Subject: demonstrate eval tracking
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Antlers.git;a=commitdiff_plain;h=699c71b861cf76e5881b373deb1e5fe3eebc6e9b

demonstrate eval tracking
---

diff --git a/lib/MooseX/Antlers/EvalTracker.pm b/lib/MooseX/Antlers/EvalTracker.pm
new file mode 100644
index 0000000..68a85cc
--- /dev/null
+++ b/lib/MooseX/Antlers/EvalTracker.pm
@@ -0,0 +1,71 @@
+package MooseX::Antlers::EvalTracker;
+
+use Moose;
+use Scalar::Util qw(weaken refaddr);
+use PadWalker qw(closed_over);
+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 'is_enabled' => (is => 'rw');
+
+sub _build__original_eval_closure {
+  Class::MOP::Method::Generated->can('_eval_closure');
+}
+
+sub _build__our_eval_closure {
+  my $eval_tracker = shift;
+  my $orig = $eval_tracker->_original_eval_closure;
+  weaken($eval_tracker); # avoid circ ref-ing $self
+  # _eval_closure returns a CODE ref and we want that too
+  sub {
+    my $self = shift;
+    # 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)};
+    my $cr = $self->$orig(@_);
+    $eval_tracker->_eval_closure_called_for($cr => @_);
+    return $cr;
+  };
+}
+
+sub enable {
+  my $self = shift;
+  return if $self->is_enabled;
+  $self->_install('our');
+  $self->is_enabled(1);
+  return;
+}
+
+sub disable {
+  my $self = shift;
+  return unless $self->is_enabled;
+  $self->_install('original');
+  $self->is_enabled(0);
+  return;
+}
+
+sub _install {
+  my ($self, $type) = @_;
+  my $code = $self->${\"_${type}_eval_closure"};
+  { # we're instrumenting the MOP so bypass it and use the old fashioned way
+    no strict 'refs'; no warnings 'redefine';
+    *Class::MOP::Method::Generated::_eval_closure = $code;
+  }
+}
+
+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);
+}
+
+sub DEMOLISH { shift->disable }
+
+1;
diff --git a/t/track_eval.t b/t/track_eval.t
new file mode 100644
index 0000000..d81fb35
--- /dev/null
+++ b/t/track_eval.t
@@ -0,0 +1,15 @@
+use strict;
+use warnings;
+use aliased 'MooseX::Antlers::EvalTracker';
+
+my $et = EvalTracker->new;
+
+$et->enable;
+
+{
+  package Foo;
+
+  use Moose;
+
+  has 'test' => (is => 'rw', trigger => sub { warn "trigger!\n" });
+}