lib/MooseX/Antlers/EvalTracker.pm

   1 package MooseX::Antlers::EvalTracker;
   2
   3 use Moose;
   4 use Scalar::Util qw(weaken refaddr);
   5 use PadWalker qw(closed_over);
   6 use namespace::clean -except => 'meta';
   7
   8 has '_original_eval_closure' => (is => 'ro', lazy_build => 1);
   9 has '_our_eval_closure' => (is => 'ro', lazy_build => 1);
  10
  11 has 'recorded_coderefs' => (is => 'ro', default => sub { {} });
  12
  13 has 'is_enabled' => (is => 'rw');
  14
  15 sub _build__original_eval_closure {
  16   Class::MOP::Method::Generated->can('_eval_closure');
  17 }
  18
  19 sub _build__our_eval_closure {
  20   my $eval_tracker = shift;
  21   my $orig = $eval_tracker->_original_eval_closure;
  22   weaken($eval_tracker); # avoid circ ref-ing $self
  23   # _eval_closure returns a CODE ref and we want that too
  24   sub {
  25     my $self = shift;
  26     # until we stop passing these let's make anything that uses it
  27     # crash out so at least we don't break anything
  28     #delete @{$_[0]}{qw($meta $attr)};
  29     my $cr = $self->$orig(@_);
  30     $eval_tracker->_eval_closure_called_for($cr => @_);
  31     return $cr;
  32   };
  33 }
  34
  35 sub enable {
  36   my $self = shift;
  37   return if $self->is_enabled;
  38   $self->_install('our');
  39   $self->is_enabled(1);
  40   return;
  41 }
  42
  43 sub disable {
  44   my $self = shift;
  45   return unless $self->is_enabled;
  46   $self->_install('original');
  47   $self->is_enabled(0);
  48   return;
  49 }
  50
  51 sub _install {
  52   my ($self, $type) = @_;
  53   my $code = $self->${\"_${type}_eval_closure"};
  54   { # we're instrumenting the MOP so bypass it and use the old fashioned way
  55     no strict 'refs'; no warnings 'redefine';
  56     *Class::MOP::Method::Generated::_eval_closure = $code;
  57   }
  58 }
  59
  60 sub _eval_closure_called_for {
  61   my ($self, $cr, $captures, $body) = @_;
  62   use Data::Dumper; $Data::Dumper::Indent = 1;
  63   my %captured = %{closed_over $cr};
  64   delete @{$captures}{grep !exists($captured{$_}), keys %$captures};
  65   warn Dumper($captures);
  66   warn Dumper($body);
  67 }
  68
  69 sub DEMOLISH { shift->disable }
  70
  71 1;