Commit | Line | Data |
699c71b8 |
1 | package MooseX::Antlers::EvalTracker; |
2 | |
3 | use Moose; |
b0fc4a7a |
4 | use MooseX::Antlers::ErrorThrower; |
699c71b8 |
5 | use Scalar::Util qw(weaken refaddr); |
6 | use PadWalker qw(closed_over); |
e4612bc2 |
7 | use Sub::Identify qw(sub_fullname); |
8 | use B qw(perlstring); |
699c71b8 |
9 | use namespace::clean -except => 'meta'; |
10 | |
11 | has '_original_eval_closure' => (is => 'ro', lazy_build => 1); |
12 | has '_our_eval_closure' => (is => 'ro', lazy_build => 1); |
13 | |
e4612bc2 |
14 | has 'recorded_coderefs' => (is => 'ro', default => sub { [] }); |
699c71b8 |
15 | |
16 | has 'is_enabled' => (is => 'rw'); |
17 | |
18 | sub _build__original_eval_closure { |
19 | Class::MOP::Method::Generated->can('_eval_closure'); |
20 | } |
21 | |
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 |
27 | sub { |
28 | my $self = shift; |
b0fc4a7a |
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."; |
31 | } |
32 | $_[0]->{'$meta'} = \'MooseX::Antlers::ErrorThrower'; |
33 | my ($cr, $e) = $self->$orig(@_); |
34 | $eval_tracker->_eval_closure_called_for($cr => @_) unless $e; |
35 | return ($cr, $e); |
699c71b8 |
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) = @_; |
699c71b8 |
66 | my %captured = %{closed_over $cr}; |
67 | delete @{$captures}{grep !exists($captured{$_}), keys %$captures}; |
e4612bc2 |
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 | ); |
699c71b8 |
100 | } |
101 | |
102 | sub DEMOLISH { shift->disable } |
103 | |
104 | 1; |