1 package MooseX::Antlers::EvalTracker;
4 use Scalar::Util qw(weaken refaddr);
5 use PadWalker qw(closed_over);
6 use Sub::Identify qw(sub_fullname);
8 use namespace::clean -except => 'meta';
10 has '_original_eval_closure' => (is => 'ro', lazy_build => 1);
11 has '_our_eval_closure' => (is => 'ro', lazy_build => 1);
13 has 'recorded_coderefs' => (is => 'ro', default => sub { [] });
15 has 'is_enabled' => (is => 'rw');
17 sub _build__original_eval_closure {
18 Class::MOP::Method::Generated->can('_eval_closure');
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
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 => @_);
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 }