slightly more convenience

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

package MooseX::Antlers::EvalTracker;

use Moose;
use MooseX::Antlers::ErrorThrower;
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';

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 _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;