metaclass dumping

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

package MooseX::Antlers::Compiler;

use Moose;
use IO::All qw(io);
use String::TT qw(strip tt);
use B qw(perlstring);
use Data::Dumper::Concise;
use Scalar::Util qw(refaddr);
use aliased 'MooseX::Antlers::RefTracker';
use aliased 'MooseX::Antlers::EvalTracker';
use aliased 'MooseX::Antlers::RefFilter';

has [ qw(_target _attr_refs _attr_et _im_et _raw_source) ] => (is => 'rw');

sub load_with_compiler {
  my ($class, $target) = @_;
  $class->new->load($target);
}

sub load {
  my ($self, $target) = @_;
  my %attr_refs;
  my %attr_et;
  my $im_et;
  my $orig_import = Moose->can('import');
  no warnings 'redefine';
  local *Moose::import = sub {
    my $targ = caller;
    Moose->$orig_import({ into => $targ });
    my $has = $targ->can('has');
    {
      no strict 'refs';
      *{"${targ}::has"} = sub {
        $attr_refs{$_[0]} = [
          map RefTracker->trace_refs( $_ => \@_ ),
            '(\@_)', '$has_args{'.perlstring($_[0]).'}'
        ];
        my $et = EvalTracker->new->enable;
        $has->(@_);
        $attr_et{$_[0]} = $et->disable;
        return;
      };
    }
  };
  my $orig_immutable = Moose::Meta::Class->can('make_immutable');
  local *Moose::Meta::Class::make_immutable = sub {
    my $et = EvalTracker->new->enable;
    $orig_immutable->(@_);
    $im_et = $et->disable;
    return;
  };
  Class::MOP::load_class($target);
  $self->_attr_refs(\%attr_refs);
  $self->_attr_et(\%attr_et);
  $self->_im_et($im_et);
  $self->_target($target);
  (my $pm_file = $target) =~ s/::/\//g;
  $self->_raw_source(scalar io($INC{"${pm_file}.pm"})->slurp);
  return $self;
}

sub compiled_source {
  my ($self) = @_;
  my %attr_et = %{$self->_attr_et};
  my %attr_refs = %{$self->_attr_refs};
  my $im_et = $self->_im_et;
  my $target = $self->_target;
  my %attr_construct;
  my $all_refs = { map %{$_->[1]}, values %attr_refs };
  foreach my $attr_name (keys %attr_refs) {
    $attr_construct{$attr_name}
      = $attr_et{$attr_name}->serialized_construction(
          $attr_refs{$attr_name}[0]
        );
  }
  my $im_construct = $im_et->serialized_construction($all_refs);
  my $preamble = tt strip q{
    my %replay_has;
    my %has_args;
    BEGIN {
      %replay_has = (
  [% FOREACH a IN attr_construct_h %]
        [% a.key %] => sub {
          [% a.value %]
        }
  [% END %]
      );
    }
    sub MooseX::Antlers::ImmutableHackFor::[% target %]::make_immutable {
      [% im_construct %]
      no warnings 'redefine';
      *[% target %]::meta = sub {
        my $meta_code = do { local $/; <[% target %]::DATA> };
        local $@;
        my $meta = eval $meta_code;
        die $@ if $@;
        $meta;
      };
    }
    use MooseX::Antlers::StealImport
      Moose => {
        -do => sub {
          strict->import;
          warnings->import;
        },
        has => sub {
          $has_args{$_[0]} = \@_;
          ($replay_has{$_[0]}||die "Can't find replay for $_[0]")
            ->(@_);
        },
        meta => sub { 'MooseX::Antlers::ImmutableHackFor::[% target %]' }
      };
  };

  my $meta_construct = $self->_meta_construction_code($all_refs);

  my $postamble = tt strip q{
    no MooseX::Antlers::StealImport qw(Moose);
    __DATA__
    [% meta_construct %]
  };

  my $compiled = join("\n", $preamble, $self->_raw_source, $postamble);

  return $compiled;
}

sub _meta_construction_code {
  my ($self, $all_refs) = @_;
  my $target = $self->_target;
  my $meta_obj = $target->meta;
  my $mappings = {
    %$all_refs,
    map +(refaddr($target->can($_)) => '\&'.$target.'::'.$_),
      $meta_obj->get_method_list, 'meta'
  };
  my $filter = RefFilter->new(
    external_mappings => $mappings,
    root_name => '$meta'
  );
  my $filtered_meta = Dumper($filter->visit($meta_obj));
  my $meta_fixup = $filter->fixup_code;
  my $target_string = perlstring($target);
  return tt strip q{
    require Moose;
    my $meta = [% filtered_meta %];
    [% meta_fixup %]
    Class::MOP::store_metaclass_by_name([% target_string %] => $meta);
    no warnings 'redefine';
    *[% target %]::meta = sub {
      Moose::Meta::Class->initialize( ref($_[0]) || $_[0] );
    };
    $meta;
  };
}

1;