lib/MooseX/Compiler.pm

   1 package MooseX::Compiler;
   2
   3 use strict;
   4 use warnings;
   5
   6 use B;
   7 use Data::Dumper;
   8 use Module::Runtime qw( module_notional_filename );
   9 use PPI::Document;
  10 use Scalar::Util qw( blessed );
  11
  12 use Moose;
  13 use Moose::Util::TypeConstraints;
  14
  15 my $moose_class = subtype, as 'ClassName', where {
  16     $_[0]->can('meta')
  17         && blessed $_[0]->meta()
  18         && $_[0]->meta()->isa('Moose::Meta::Class');
  19 };
  20
  21 has class => (
  22     is       => 'ro',
  23     isa      => $moose_class,
  24     required => 1,
  25 );
  26
  27 has _class_meta => (
  28     is       => 'ro',
  29     isa      => 'Moose::Meta::Class',
  30     init_arg => undef,
  31     lazy     => 1,
  32     default  => sub { $_[0]->class()->meta() },
  33 );
  34
  35 has _ppi_document => (
  36     is       => 'ro',
  37     isa      => 'PPI::Document',
  38     init_arg => undef,
  39     lazy     => 1,
  40     builder  => '_build_ppi_document',
  41 );
  42
  43 has _package_statement => (
  44     is       => 'ro',
  45     isa      => 'PPI::Statement::Package',
  46     init_arg => undef,
  47     lazy     => 1,
  48     builder  => '_build_package_statement',
  49 );
  50
  51 sub compile_class {
  52     my $self = shift;
  53
  54     $self->_modify_class_content();
  55     $self->_inline_roles();
  56     $self->_inline_constructor();
  57     $self->_inline_attributes();
  58
  59     return $self->_ppi_document()->content();
  60 }
  61
  62 sub _modify_class_content {
  63     my $self = shift;
  64
  65     $self->_fixup_line_numbers();
  66     $self->_do_not_use_moose();
  67     $self->_inline_parents();
  68     $self->_load_required_modules();
  69
  70     return;
  71 }
  72
  73 sub _fixup_line_numbers {
  74     my $self = shift;
  75
  76     my $code = "#line 3\n";
  77     $self->_package_statement()->snext_sibling()->insert_before( $_->clone() )
  78         for PPI::Document->new( \$code )->children();
  79
  80     return;
  81 }
  82
  83 sub _do_not_use_moose {
  84     my $self = shift;
  85
  86     my $use_nodes = $self->_ppi_document()->find(
  87         sub {
  88             my $node = $_[1];
  89             return undef
  90                 if $node->isa('PPI::Statement')
  91                     && !$node->isa('PPI::Statement::Include');
  92             return undef if $node->isa('PPI::Structure');
  93             return 1
  94                 if $node->isa('PPI::Statement::Include')
  95                     && $node->module() =~ /^Moose/;
  96             return 0;
  97         }
  98     );
  99
 100     for my $node ( @{$use_nodes} ) {
 101         my $replacement_code .=
 102             defined $node->module_version()
 103             ? join(
 104             q{ },
 105             'use', $node->module(), $node->module_version(), '()', ';',
 106             )
 107             : '# ' . $node->content();
 108
 109         $node->insert_before( $_->clone() )
 110             for PPI::Document->new( \$replacement_code )->children();
 111         $node->remove();
 112     }
 113
 114     return;
 115 }
 116
 117 sub _inline_parents {
 118     my $self = shift;
 119
 120     my @supers = $self->_class_meta()->superclasses();
 121     return unless @supers;
 122
 123     my $code = 'use parent ';
 124     $code .= join ', ', map { B::perlstring($_) } @supers;
 125     $code .= ";\n";
 126
 127     $self->_package_statement()->insert_after( $_->clone() )
 128         for PPI::Document->new( \$code )->children();
 129
 130     return;
 131 }
 132
 133 # XXX - replace this with something that looks at all the generated code for
 134 # calls of the form Foo::Bar::quux(...) - also don't load modules that are
 135 # already being used.
 136 sub _load_required_modules {
 137     my $self = shift;
 138
 139     my $code = "use Scalar::Util ();\nuse Moose::Error::Util ();\nuse Carp ();\n";
 140
 141     $self->_package_statement()->insert_after( $_->clone() )
 142         for PPI::Document->new( \$code )->children();
 143
 144     return;
 145 }
 146
 147 sub _inline_roles {
 148     return;
 149 }
 150
 151 sub _inline_constructor {
 152     my $self = shift;
 153
 154     my $environment = $self->_class_meta()->_eval_environment();
 155     delete $environment->{'$meta'};
 156     delete $environment->{'@type_constraint_bodies'};
 157
 158     if ( grep { defined } @{ ${ $environment->{'$triggers'} } || [] } ) {
 159         die 'Cannot compile a class with triggers for attributes';
 160     }
 161
 162     my $body = join "\n", $self->_class_meta()->_inline_new_object();
 163     if ( $body =~ /\$meta/ ) {
 164         die
 165             'Cannot compile a class with a constructor that refers to the $meta object';
 166     }
 167
 168     my @defs = @{ ${ $environment->{'$defaults'} } };
 169     $environment->{'$defaults'} = \(
 170         [
 171             map { ref $defs[$_] ? '$___attributes[' . $_ . ']' : $defs[$_] }
 172                 0 .. $#defs
 173         ]
 174     );
 175
 176     my $constructor = join "\n", (
 177         '{',
 178         (
 179             map {
 180                 $self->_serialize_assignment( $_, $environment->{$_} ) . ';'
 181                 }
 182                 keys %{$environment}
 183         ),
 184         'sub new {',
 185         $body,
 186         '}',
 187         '}',
 188     );
 189
 190     $constructor .= "\n\n";
 191
 192     $self->_insert_before_end($constructor);
 193
 194     return;
 195 }
 196
 197 sub _serialize_assignment {
 198     my $self  = shift;
 199     my $name  = shift;
 200     my $value = shift;
 201
 202     local $Data::Dumper::Terse     = 1;
 203     local $Data::Dumper::Indent    = 1;
 204     local $Data::Dumper::Useqq     = 1;
 205     local $Data::Dumper::Deparse   = 1;
 206     local $Data::Dumper::Quotekeys = 0;
 207     local $Data::Dumper::Sortkeys  = 1;
 208
 209     return
 210           "$name = "
 211         . substr( $name, 0, 1 ) . '{ '
 212         . Data::Dumper->Dump( [$value] ) . ' }';
 213 }
 214
 215 sub _inline_attributes {
 216     return;
 217 }
 218
 219 sub _insert_before_end {
 220     my $self = shift;
 221     my $code = shift;
 222
 223     my $end_node = $self->_ppi_document()->find_first(
 224         sub {
 225             my $node = $_[1];
 226
 227             return 1
 228                 if $node->isa('PPI::Statement') && $node->content() =~ /^1;/;
 229             return 0;
 230         }
 231     );
 232
 233     die 'Cannot find the end of the class (looking for a line match /^1;/)'
 234         unless $end_node;
 235
 236     $end_node->insert_before( $_->clone() )
 237         for PPI::Document->new( \$code )->children();
 238
 239     return;
 240 }
 241
 242 sub _build_ppi_document {
 243     my $self = shift;
 244
 245     my $pm_file       = module_notional_filename( $self->class() );
 246     my $path_to_class = $INC{$pm_file}
 247         or die "Cannot find $pm_file in %INC!";
 248
 249     return PPI::Document->new( $path_to_class->stringify() )
 250         or die PPI::Document->errstr();
 251 }
 252
 253 sub _build_package_statement {
 254     my $self = shift;
 255
 256     my $package_stmt = $self->_ppi_document()->find_first(
 257         sub {
 258             my $node = $_[1];
 259             return 1 if $_[1]->isa('PPI::Statement::Package');
 260             return 0;
 261         }
 262     );
 263
 264     die 'Cannot find a package statement in this code'
 265         unless $package_stmt;
 266
 267     return $package_stmt;
 268 }
 269
 270 __PACKAGE__->meta()->make_immutable();
 271
 272 1;