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 aliased 'MooseX::Antlers::RefTracker';
   8 use aliased 'MooseX::Antlers::EvalTracker';
   9 use aliased 'MooseX::Antlers::RefFilter';
  10
  11 has [ qw(_target _attr_refs _attr_et _im_et _raw_source) ] => (is => 'rw');
  12
  13 sub load_with_compiler {
  14   my ($class, $target) = @_;
  15   $class->new->load($target);
  16 }
  17
  18 sub load {
  19   my ($self, $target) = @_;
  20   my %attr_refs;
  21   my %attr_et;
  22   my $im_et;
  23   my $orig_import = Moose->can('import');
  24   no warnings 'redefine';
  25   local *Moose::import = sub {
  26     my $targ = caller;
  27     Moose->$orig_import({ into => $targ });
  28     my $has = $targ->can('has');
  29     {
  30       no strict 'refs';
  31       *{"${targ}::has"} = sub {
  32         $attr_refs{$_[0]} = [
  33           map RefTracker->trace_refs( $_ => \@_ ),
  34             '(\@_)', '$has_args{'.perlstring($_[0]).'}'
  35         ];
  36         my $et = EvalTracker->new->enable;
  37         $has->(@_);
  38         $attr_et{$_[0]} = $et->disable;
  39         return;
  40       };
  41     }
  42   };
  43   my $orig_immutable = Moose::Meta::Class->can('make_immutable');
  44   local *Moose::Meta::Class::make_immutable = sub {
  45     my $et = EvalTracker->new->enable;
  46     $orig_immutable->(@_);
  47     $im_et = $et->disable;
  48     return;
  49   };
  50   Class::MOP::load_class($target);
  51   $self->_attr_refs(\%attr_refs);
  52   $self->_attr_et(\%attr_et);
  53   $self->_im_et($im_et);
  54   $self->_target($target);
  55   (my $pm_file = $target) =~ s/::/\//g;
  56   $self->_raw_source(scalar io($INC{"${pm_file}.pm"})->slurp);
  57   return $self;
  58 }
  59
  60 sub compiled_source {
  61   my ($self) = @_;
  62   my %attr_et = %{$self->_attr_et};
  63   my %attr_refs = %{$self->_attr_refs};
  64   my $im_et = $self->_im_et;
  65   my $target = $self->_target;
  66   my %attr_construct;
  67   foreach my $attr_name (keys %attr_refs) {
  68     $attr_construct{$attr_name}
  69       = $attr_et{$attr_name}->serialized_construction(
  70           $attr_refs{$attr_name}[0]
  71         );
  72   }
  73   my $im_construct = $im_et->serialized_construction(
  74     { map %{$_->[1]}, values %attr_refs }
  75   );
  76   my $preamble = strip tt q{
  77     my %replay_has;
  78     my %has_args;
  79     BEGIN {
  80       %replay_has = (
  81   [% FOREACH a IN attr_construct_h %]
  82         [% a.key %] => sub {
  83           [% a.value %]
  84         }
  85   [% END %]
  86       );
  87     }
  88     sub MooseX::Antlers::ImmutableHackFor::[% target %]::make_immutable {
  89   [% im_construct %]
  90     }
  91     use MooseX::Antlers::StealImport
  92       Moose => {
  93         -do => sub {
  94           strict->import;
  95           warnings->import;
  96         },
  97         has => sub {
  98           $has_args{$_[0]} = \@_;
  99           ($replay_has{$_[0]}||die "Can't find replay for $_[0]")
 100             ->(@_);
 101         },
 102         meta => sub { 'MooseX::Antlers::ImmutableHackFor::[% target %]' }
 103       };
 104   };
 105
 106   my $postamble = strip q{
 107     no MooseX::Antlers::StealImport qw(Moose);
 108   };
 109
 110   my $compiled = join("\n", $preamble, $self->_raw_source, $postamble);
 111
 112   return $compiled;
 113 }
 114
 115 1;