lib/MooseX/Antlers/Compiler.pm

   1 package MooseX::Antlers::Compiler;
   2
   3 use Moose;
   4 use IO::All qw(io);
   5 use String::TT qw(strip tt);
   6 use B qw(perlstring);
   7 use Sub::Name qw/subname/;
   8 use Data::Dumper::Concise;
   9 use Scalar::Util qw(refaddr);
  10 use aliased 'MooseX::Antlers::RefTracker';
  11 use aliased 'MooseX::Antlers::EvalTracker';
  12 use aliased 'MooseX::Antlers::RefFilter';
  13
  14 has [ qw(_target _attr_refs _attr_et _im_et _raw_source) ] => (is => 'rw');
  15
  16 sub load_with_compiler {
  17   my ($class, $target) = @_;
  18   $class->new->load($target);
  19 }
  20
  21 sub load {
  22   my ($self, $target) = @_;
  23   my %attr_refs;
  24   my %attr_et;
  25   my $im_et;
  26   my $orig_import = Moose->can('import');
  27   no warnings 'redefine';
  28   local *Moose::import = sub {
  29     my $targ = caller;
  30     Moose->$orig_import({ into => $targ });
  31     my $has = $targ->can('has');
  32     {
  33       no strict 'refs';
  34       *{"${targ}::has"} = sub {
  35         $attr_refs{$_[0]} = [
  36           map RefTracker->trace_refs( $_ => \@_ ),
  37             '(\@_)', '$has_args{'.perlstring($_[0]).'}'
  38         ];
  39         my $et = EvalTracker->new->enable;
  40         $has->(@_);
  41         $attr_et{$_[0]} = $et->disable;
  42         return;
  43       };
  44     }
  45   };
  46   my $orig_immutable = Moose::Meta::Class->can('make_immutable');
  47   local *Moose::Meta::Class::make_immutable = subname 'MooseX::Antlers::Compiler::make_immutable' => sub {
  48     my $et = EvalTracker->new->enable;
  49     $orig_immutable->(@_);
  50     $im_et = $et->disable;
  51     return;
  52   };
  53   Class::MOP::load_class($target);
  54   $self->_attr_refs(\%attr_refs);
  55   $self->_attr_et(\%attr_et);
  56   $self->_im_et($im_et);
  57   $self->_target($target);
  58   (my $pm_file = $target) =~ s/::/\//g;
  59   $self->_raw_source(scalar io($INC{"${pm_file}.pm"})->slurp);
  60   return $self;
  61 }
  62
  63 sub compiled_source {
  64   my ($self) = @_;
  65   my %attr_et = %{$self->_attr_et};
  66   my %attr_refs = %{$self->_attr_refs};
  67   my $im_et = $self->_im_et;
  68   my $target = $self->_target;
  69   my %attr_construct;
  70   my $all_refs = { map %{$_->[1]}, values %attr_refs };
  71   foreach my $attr_name (keys %attr_refs) {
  72     $attr_construct{$attr_name}
  73       = $attr_et{$attr_name}->serialized_construction(
  74           $attr_refs{$attr_name}[0]
  75         );
  76   }
  77   my $im_construct = $im_et->serialized_construction($all_refs);
  78   my $preamble = tt strip q{
  79     use Sub::Name ();
  80     my %replay_has;
  81     my %has_args;
  82     BEGIN {
  83       %replay_has = (
  84     [% FOREACH a IN attr_construct_h %]
  85         [% a.key %] => sub {
  86           [% a.value %]
  87         }
  88     [% END %]
  89       );
  90     }
  91     sub MooseX::Antlers::ImmutableHackFor::[% target %]::make_immutable {
  92       [% im_construct %]
  93       no warnings 'redefine';
  94       *[% target %]::meta = sub {
  95         my $meta_code = do { local $/; <[% target %]::DATA> };
  96         local $@;
  97         my $meta = eval $meta_code;
  98         die $@ if $@;
  99         $meta;
 100       };
 101     }
 102     use MooseX::Antlers::StealImport
 103       Moose => {
 104         -do => sub {
 105           strict->import;
 106           warnings->import;
 107         },
 108         has => sub {
 109           $has_args{$_[0]} = \@_;
 110           ($replay_has{$_[0]}||die "Can't find replay for $_[0]")
 111             ->(@_);
 112         },
 113         meta => sub { 'MooseX::Antlers::ImmutableHackFor::[% target %]' }
 114       };
 115   };
 116
 117   my $meta_construct = $self->_meta_construction_code($all_refs);
 118
 119   my $postamble = tt strip q{
 120     no MooseX::Antlers::StealImport qw(Moose);
 121     __DATA__
 122     [% meta_construct %]
 123   };
 124
 125   my $compiled = join("\n", $preamble, $self->_raw_source, $postamble);
 126
 127   return $compiled;
 128 }
 129
 130 sub _meta_construction_code {
 131   my ($self, $all_refs) = @_;
 132   my $target = $self->_target;
 133   my $meta_obj = $target->meta;
 134   my $mappings = {
 135     %$all_refs,
 136     map +(refaddr($target->can($_)) => '\&'.$target.'::'.$_),
 137       $meta_obj->get_method_list, 'meta'
 138   };
 139   my $filter = RefFilter->new(
 140     external_mappings => $mappings,
 141     root_name => '$meta'
 142   );
 143   my $filtered_meta = Dumper($filter->visit($meta_obj));
 144   my $meta_fixup = $filter->fixup_code;
 145   my $target_string = perlstring($target);
 146   return tt strip q{
 147     require Moose;
 148     my $meta = [% filtered_meta %];
 149     [% meta_fixup %]
 150     Class::MOP::store_metaclass_by_name([% target_string %] => $meta);
 151     no warnings 'redefine';
 152     *[% target %]::meta = sub {
 153       Moose::Meta::Class->initialize( ref($_[0]) || $_[0] );
 154     };
 155     $meta;
 156   };
 157 }
 158
 159 1;