serialising roughly the right things in roughly the right order

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

package MooseX::Antlers::EvalTracker;

use Moose;
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;
    # ... screwed over here by $attr->default(...) and ->trigger(...)
    # in the bloody inlined subs. XXX slap stevan, fix Moose
    # until we stop passing these let's make anything that uses it
    # crash out so at least we don't break anything
    #delete @{$_[0]}{qw($meta $attr)};
    my $cr = $self->$orig(@_);
    $eval_tracker->_eval_closure_called_for($cr => @_);
    return $cr;
  };
}

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

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

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;