Commit | Line | Data |
699c71b8 |
1 | package MooseX::Antlers::EvalTracker; |
2 | |
3 | use Moose; |
b0fc4a7a |
4 | use MooseX::Antlers::ErrorThrower; |
064721e6 |
5 | use aliased 'MooseX::Antlers::RefFilter'; |
699c71b8 |
6 | use Scalar::Util qw(weaken refaddr); |
7 | use PadWalker qw(closed_over); |
e4612bc2 |
8 | use Sub::Identify qw(sub_fullname); |
9 | use B qw(perlstring); |
699c71b8 |
10 | use namespace::clean -except => 'meta'; |
064721e6 |
11 | use String::TT qw(tt strip); |
12 | use Data::Dumper::Concise; |
699c71b8 |
13 | |
14 | has '_original_eval_closure' => (is => 'ro', lazy_build => 1); |
15 | has '_our_eval_closure' => (is => 'ro', lazy_build => 1); |
16 | |
e4612bc2 |
17 | has 'recorded_coderefs' => (is => 'ro', default => sub { [] }); |
699c71b8 |
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; |
b0fc4a7a |
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); |
699c71b8 |
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); |
5ed50637 |
47 | return $self; |
699c71b8 |
48 | } |
49 | |
50 | sub disable { |
51 | my $self = shift; |
52 | return unless $self->is_enabled; |
53 | $self->_install('original'); |
54 | $self->is_enabled(0); |
5ed50637 |
55 | return $self; |
699c71b8 |
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) = @_; |
699c71b8 |
69 | my %captured = %{closed_over $cr}; |
70 | delete @{$captures}{grep !exists($captured{$_}), keys %$captures}; |
e4612bc2 |
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 | |
064721e6 |
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 | |
e4612bc2 |
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 | ); |
699c71b8 |
133 | } |
134 | |
135 | sub DEMOLISH { shift->disable } |
136 | |
137 | 1; |