1 package MooseX::Antlers::EvalTracker;
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);
10 use namespace::clean -except => 'meta';
11 use String::TT qw(tt strip);
12 use Data::Dumper::Concise;
14 has '_original_eval_closure' => (is => 'ro', lazy_build => 1);
15 has '_our_eval_closure' => (is => 'ro', lazy_build => 1);
17 has 'recorded_coderefs' => (is => 'ro', default => sub { [] });
19 has 'is_enabled' => (is => 'rw');
21 sub _build__original_eval_closure {
22 Class::MOP::Method::Generated->can('_eval_closure');
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
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.";
35 $_[0]->{'$meta'} = \'MooseX::Antlers::ErrorThrower';
36 my ($cr, $e) = $self->$orig(@_);
37 $eval_tracker->_eval_closure_called_for($cr => @_) unless $e;
44 return if $self->is_enabled;
45 $self->_install('our');
52 return unless $self->is_enabled;
53 $self->_install('original');
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;
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);
77 sub serialized_construction {
78 my ($self, $externals) = @_;
80 package Class::MOP::Method::Generated;
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'
92 my $filtered_captures = Dumper($filter->visit($captures));
93 my $fixup_code = $filter->fixup_code;
94 my $use_captures = $self->_generate_capture_constructor($captures);
97 my $__captures = [% filtered_captures %];
100 *[% name %] = Sub::Name::subname [% name_string %] => [% body %];
107 sub _generate_coderef_constructor {
108 my ($self, $entry) = @_;
109 my ($cr, $captures, $body) = @{$entry};
110 my $name = sub_fullname($cr);
114 ' my $__captures = shift;',
115 $self->_generate_capture_constructor($captures),
117 'return *'.$name.' = Sub::Name::subname '.perlstring($name).' =>',
123 sub _generate_capture_constructor {
124 my ($self, $captures) = @_;
128 /^([\@\%\$])/ or die "capture key should start with \@, \% or \$: $_";
129 q! my !.$_.q! = !.$1.q!{$__captures->{'!.$_.q!'}};!;
135 sub DEMOLISH { shift->disable }