this, sort of, works

[gitmo/MooseX-Antlers.git] / lib / MooseX / Antlers / EvalTracker.pm

package MooseX::Antlers::EvalTracker;

use Moose;
use MooseX::Antlers::ErrorThrower;
use aliased 'MooseX::Antlers::RefFilter';
use Scalar::Util qw(weaken refaddr);
use PadWalker qw(closed_over);
use Sub::Identify qw(sub_fullname);
use B qw(perlstring);
use namespace::clean -except => 'meta';
use String::TT qw(tt strip);
use Data::Dumper::Concise;

has '_original_eval_closure' => (is => 'ro', lazy_build => 1);
has '_our_eval_closure' => (is => 'ro', lazy_build => 1);

has 'recorded_coderefs' => (is => 'ro', default => sub { [] });

has 'is_enabled' => (is => 'rw');

sub _build__original_eval_closure {
  Class::MOP::Method::Generated->can('_eval_closure');
}

sub _build__our_eval_closure {
  my $eval_tracker = shift;
  my $orig = $eval_tracker->_original_eval_closure;
  weaken($eval_tracker); # avoid circ ref-ing $self
  # _eval_closure returns a CODE ref and we want that too
  sub {
    my $self = shift;
    if ($_[0]->{'$attr'} || $_[0]->{'$attrs'}) {
      die "Closing over meta-attribute, can't handle this. Suspect you used initializer - can't support that yet, sorry. Patches welcome.";
    }
    $_[0]->{'$meta'} = \'MooseX::Antlers::ErrorThrower';
    my ($cr, $e) = $self->$orig(@_);
    $eval_tracker->_eval_closure_called_for($cr => @_) unless $e;
    return ($cr, $e);
  };
}

sub enable {
  my $self = shift;
  return if $self->is_enabled;
  $self->_install('our');
  $self->is_enabled(1);
  return $self;
}

sub disable {
  my $self = shift;
  return unless $self->is_enabled;
  $self->_install('original');
  $self->is_enabled(0);
  return $self;
}

sub _install {
  my ($self, $type) = @_;
  my $code = $self->${\"_${type}_eval_closure"};
  { # we're instrumenting the MOP so bypass it and use the old fashioned way
    no strict 'refs'; no warnings 'redefine';
    *Class::MOP::Method::Generated::_eval_closure = $code;
  }
}

sub _eval_closure_called_for {
  my ($self, $cr, $captures, $body) = @_;
  my %captured = %{closed_over $cr};
  delete @{$captures}{grep !exists($captured{$_}), keys %$captures};
  push(@{$self->recorded_coderefs}, [ $cr, $captures, $body ]);
  #use Data::Dumper; $Data::Dumper::Indent = 1;
  #warn Dumper($captures);
  #warn Dumper($body);
}

sub serialized_construction {
  my ($self, $externals) = @_;
  my $code = strip q{
    package Class::MOP::Method::Generated;
    use strict;
    use warnings;
  };
  foreach my $recorded (@{$self->recorded_coderefs}) {
    my ($cr, $captures, $body) = @{$recorded};
    my $name = sub_fullname($cr);
    my $name_string = perlstring($name);
    my $filter = RefFilter->new(
      external_mappings => $externals,
      root_name => '$__captures'
    );
    my $filtered_captures = Dumper($filter->visit($captures));
    my $fixup_code = $filter->fixup_code;
    my $use_captures = $self->_generate_capture_constructor($captures);
    $code .= strip tt q{
      {
        my $__captures = [% filtered_captures %];
        [% fixup_code %]
        [% use_captures %]
        *[% name %] = Sub::Name::subname [% name_string %] => [% body %];
      }
    };
  }
  return $code;
}
    
sub _generate_coderef_constructor {
  my ($self, $entry) = @_;
  my ($cr, $captures, $body) = @{$entry};
  my $name = sub_fullname($cr);
  join(
    "\n",
    "sub {",
    '  my $__captures = shift;',
    $self->_generate_capture_constructor($captures),
    'use Sub::Name ();',
    'return *'.$name.' = Sub::Name::subname '.perlstring($name).' =>',
    "${body};",
    '}',
  );
}

sub _generate_capture_constructor {
  my ($self, $captures) = @_;
  join(
    "\n",
    (map {
      /^([\@\%\$])/ or die "capture key should start with \@, \% or \$: $_";
      q!  my !.$_.q! = !.$1.q!{$__captures->{'!.$_.q!'}};!;
    } keys %$captures),
    '' # trailing \n
  );
}

sub DEMOLISH { shift->disable }

1;