lib/MooseX/Antlers/EvalTracker.pm

   1 package MooseX::Antlers::EvalTracker;
   2
   3 use Moose;
   4 use MooseX::Antlers::ErrorThrower;
   5 use aliased 'MooseX::Antlers::RefFilter';
   6 use Scalar::Util qw(weaken refaddr);
   7 use PadWalker qw(closed_over);
   8 use Sub::Identify qw(sub_fullname);
   9 use B qw(perlstring);
  10 use namespace::clean -except => 'meta';
  11 use String::TT qw(tt strip);
  12 use Data::Dumper::Concise;
  13
  14 has '_original_eval_closure' => (is => 'ro', lazy_build => 1);
  15 has '_our_eval_closure' => (is => 'ro', lazy_build => 1);
  16
  17 has 'recorded_coderefs' => (is => 'ro', default => sub { [] });
  18
  19 has 'is_enabled' => (is => 'rw');
  20
  21 sub _build__original_eval_closure {
  22   Class::MOP::Method::Generated->can('_eval_closure');
  23 }
  24
  25 sub _build__our_eval_closure {
  26   my $eval_tracker = shift;
  27   my $orig = $eval_tracker->_original_eval_closure;
  28   weaken($eval_tracker); # avoid circ ref-ing $self
  29   # _eval_closure returns a CODE ref and we want that too
  30   sub {
  31     my $self = shift;
  32     if ($_[0]->{'$attr'} || $_[0]->{'$attrs'}) {
  33       die "Closing over meta-attribute, can't handle this. Suspect you used initializer - can't support that yet, sorry. Patches welcome.";
  34     }
  35     $_[0]->{'$meta'} = \'MooseX::Antlers::ErrorThrower';
  36     my ($cr, $e) = $self->$orig(@_);
  37     $eval_tracker->_eval_closure_called_for($cr => @_) unless $e;
  38     return ($cr, $e);
  39   };
  40 }
  41
  42 sub enable {
  43   my $self = shift;
  44   return if $self->is_enabled;
  45   $self->_install('our');
  46   $self->is_enabled(1);
  47   return $self;
  48 }
  49
  50 sub disable {
  51   my $self = shift;
  52   return unless $self->is_enabled;
  53   $self->_install('original');
  54   $self->is_enabled(0);
  55   return $self;
  56 }
  57
  58 sub _install {
  59   my ($self, $type) = @_;
  60   my $code = $self->${\"_${type}_eval_closure"};
  61   { # we're instrumenting the MOP so bypass it and use the old fashioned way
  62     no strict 'refs'; no warnings 'redefine';
  63     *Class::MOP::Method::Generated::_eval_closure = $code;
  64   }
  65 }
  66
  67 sub _eval_closure_called_for {
  68   my ($self, $cr, $captures, $body) = @_;
  69   my %captured = %{closed_over $cr};
  70   delete @{$captures}{grep !exists($captured{$_}), keys %$captures};
  71   push(@{$self->recorded_coderefs}, [ $cr, $captures, $body ]);
  72   #use Data::Dumper; $Data::Dumper::Indent = 1;
  73   #warn Dumper($captures);
  74   #warn Dumper($body);
  75 }
  76
  77 sub serialized_construction {
  78   my ($self, $externals) = @_;
  79   my $code = strip q{
  80     package Class::MOP::Method::Generated;
  81     use strict;
  82     use warnings;
  83   };
  84   foreach my $recorded (@{$self->recorded_coderefs}) {
  85     my ($cr, $captures, $body) = @{$recorded};
  86     my $name = sub_fullname($cr);
  87     my $name_string = perlstring($name);
  88     my $filter = RefFilter->new(
  89       external_mappings => $externals,
  90       root_name => '$__captures'
  91     );
  92     my $filtered_captures = Dumper($filter->visit($captures));
  93     my $fixup_code = $filter->fixup_code;
  94     my $use_captures = $self->_generate_capture_constructor($captures);
  95     $code .= strip tt q{
  96       {
  97         my $__captures = [% filtered_captures %];
  98         [% fixup_code %]
  99         [% use_captures %]
 100         *[% name %] = Sub::Name::subname [% name_string %] => [% body %];
 101       }
 102     };
 103   }
 104   return $code;
 105 }
 106
 107 sub _generate_coderef_constructor {
 108   my ($self, $entry) = @_;
 109   my ($cr, $captures, $body) = @{$entry};
 110   my $name = sub_fullname($cr);
 111   join(
 112     "\n",
 113     "sub {",
 114     '  my $__captures = shift;',
 115     $self->_generate_capture_constructor($captures),
 116     'use Sub::Name ();',
 117     'return *'.$name.' = Sub::Name::subname '.perlstring($name).' =>',
 118     "${body};",
 119     '}',
 120   );
 121 }
 122
 123 sub _generate_capture_constructor {
 124   my ($self, $captures) = @_;
 125   join(
 126     "\n",
 127     (map {
 128       /^([\@\%\$])/ or die "capture key should start with \@, \% or \$: $_";
 129       q!  my !.$_.q! = !.$1.q!{$__captures->{'!.$_.q!'}};!;
 130     } keys %$captures),
 131     '' # trailing \n
 132   );
 133 }
 134
 135 sub DEMOLISH { shift->disable }
 136
 137 1;