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 Sub::Identify qw(sub_fullname);
   7 use B qw(perlstring);
   8 use namespace::clean -except => 'meta';
   9
  10 has '_original_eval_closure' => (is => 'ro', lazy_build => 1);
  11 has '_our_eval_closure' => (is => 'ro', lazy_build => 1);
  12
  13 has 'recorded_coderefs' => (is => 'ro', default => sub { [] });
  14
  15 has 'is_enabled' => (is => 'rw');
  16
  17 sub _build__original_eval_closure {
  18   Class::MOP::Method::Generated->can('_eval_closure');
  19 }
  20
  21 sub _build__our_eval_closure {
  22   my $eval_tracker = shift;
  23   my $orig = $eval_tracker->_original_eval_closure;
  24   weaken($eval_tracker); # avoid circ ref-ing $self
  25   # _eval_closure returns a CODE ref and we want that too
  26   sub {
  27     my $self = shift;
  28     # ... screwed over here by $attr->default(...) and ->trigger(...)
  29     # in the bloody inlined subs. XXX slap stevan, fix Moose
  30     # until we stop passing these let's make anything that uses it
  31     # crash out so at least we don't break anything
  32     #delete @{$_[0]}{qw($meta $attr)};
  33     my $cr = $self->$orig(@_);
  34     $eval_tracker->_eval_closure_called_for($cr => @_);
  35     return $cr;
  36   };
  37 }
  38
  39 sub enable {
  40   my $self = shift;
  41   return if $self->is_enabled;
  42   $self->_install('our');
  43   $self->is_enabled(1);
  44   return;
  45 }
  46
  47 sub disable {
  48   my $self = shift;
  49   return unless $self->is_enabled;
  50   $self->_install('original');
  51   $self->is_enabled(0);
  52   return;
  53 }
  54
  55 sub _install {
  56   my ($self, $type) = @_;
  57   my $code = $self->${\"_${type}_eval_closure"};
  58   { # we're instrumenting the MOP so bypass it and use the old fashioned way
  59     no strict 'refs'; no warnings 'redefine';
  60     *Class::MOP::Method::Generated::_eval_closure = $code;
  61   }
  62 }
  63
  64 sub _eval_closure_called_for {
  65   my ($self, $cr, $captures, $body) = @_;
  66   my %captured = %{closed_over $cr};
  67   delete @{$captures}{grep !exists($captured{$_}), keys %$captures};
  68   push(@{$self->recorded_coderefs}, [ $cr, $captures, $body ]);
  69   #use Data::Dumper; $Data::Dumper::Indent = 1;
  70   #warn Dumper($captures);
  71   #warn Dumper($body);
  72 }
  73
  74 sub _generate_coderef_constructor {
  75   my ($self, $entry) = @_;
  76   my ($cr, $captures, $body) = @{$entry};
  77   my $name = sub_fullname($cr);
  78   join(
  79     "\n",
  80     "sub {",
  81     '  my $__captures = shift;',
  82     $self->_generate_capture_constructor($captures),
  83     'use Sub::Name ();',
  84     'return *'.$name.' = Sub::Name::subname '.perlstring($name).' =>',
  85     "${body};",
  86     '}',
  87   );
  88 }
  89
  90 sub _generate_capture_constructor {
  91   my ($self, $captures) = @_;
  92   join(
  93     "\n",
  94     (map {
  95       /^([\@\%\$])/ or die "capture key should start with \@, \% or \$: $_";
  96       q!  my !.$_.q! = !.$1.q!{$__captures->{'!.$_.q!'}};!;
  97     } keys %$captures),
  98     '' # trailing \n
  99   );
 100 }
 101
 102 sub DEMOLISH { shift->disable }
 103
 104 1;