1 package MooseX::Antlers::EvalTracker;
4 use MooseX::Antlers::ErrorThrower;
5 use Scalar::Util qw(weaken refaddr);
6 use PadWalker qw(closed_over);
7 use Sub::Identify qw(sub_fullname);
9 use namespace::clean -except => 'meta';
11 has '_original_eval_closure' => (is => 'ro', lazy_build => 1);
12 has '_our_eval_closure' => (is => 'ro', lazy_build => 1);
14 has 'recorded_coderefs' => (is => 'ro', default => sub { [] });
16 has 'is_enabled' => (is => 'rw');
18 sub _build__original_eval_closure {
19 Class::MOP::Method::Generated->can('_eval_closure');
22 sub _build__our_eval_closure {
23 my $eval_tracker = shift;
24 my $orig = $eval_tracker->_original_eval_closure;
25 weaken($eval_tracker); # avoid circ ref-ing $self
26 # _eval_closure returns a CODE ref and we want that too
29 if ($_[0]->{'$attr'} || $_[0]->{'$attrs'}) {
30 die "Closing over meta-attribute, can't handle this. Suspect you used initializer - can't support that yet, sorry. Patches welcome.";
32 $_[0]->{'$meta'} = \'MooseX::Antlers::ErrorThrower';
33 my ($cr, $e) = $self->$orig(@_);
34 $eval_tracker->_eval_closure_called_for($cr => @_) unless $e;
41 return if $self->is_enabled;
42 $self->_install('our');
49 return unless $self->is_enabled;
50 $self->_install('original');
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;
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);
74 sub _generate_coderef_constructor {
75 my ($self, $entry) = @_;
76 my ($cr, $captures, $body) = @{$entry};
77 my $name = sub_fullname($cr);
81 ' my $__captures = shift;',
82 $self->_generate_capture_constructor($captures),
84 'return *'.$name.' = Sub::Name::subname '.perlstring($name).' =>',
90 sub _generate_capture_constructor {
91 my ($self, $captures) = @_;
95 /^([\@\%\$])/ or die "capture key should start with \@, \% or \$: $_";
96 q! my !.$_.q! = !.$1.q!{$__captures->{'!.$_.q!'}};!;
102 sub DEMOLISH { shift->disable }