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 rename_to => (
  28     is        => 'ro',
  29     isa       => 'Str',
  30     predicate => '_has_rename_to',
  31 );
  32
  33 has _class_meta => (
  34     is       => 'ro',
  35     isa      => 'Moose::Meta::Class',
  36     init_arg => undef,
  37     lazy     => 1,
  38     default  => sub { $_[0]->class()->meta() },
  39 );
  40
  41 has _ppi_document => (
  42     is       => 'ro',
  43     isa      => 'PPI::Document',
  44     init_arg => undef,
  45     lazy     => 1,
  46     builder  => '_build_ppi_document',
  47 );
  48
  49 has _package_statement => (
  50     is       => 'ro',
  51     isa      => 'PPI::Statement::Package',
  52     init_arg => undef,
  53     lazy     => 1,
  54     builder  => '_build_package_statement',
  55     clearer  => '_clear_package_statement',
  56 );
  57
  58 has _end_node => (
  59     is       => 'ro',
  60     isa      => 'PPI::Statement',
  61     init_arg => undef,
  62     lazy     => 1,
  63     builder  => '_build_end_node',
  64 );
  65
  66 sub compile_class {
  67     my $self = shift;
  68
  69     $self->_sanity_check_class();
  70     $self->_modify_class_content();
  71     $self->_inline_roles();
  72     $self->_inline_constructor();
  73     $self->_inline_attributes();
  74
  75     return $self->_ppi_document()->content();
  76 }
  77
  78 sub _sanity_check_class {
  79     my $self = shift;
  80
  81     for my $attr ( $self->_class_meta()->get_all_attributes() ) {
  82         if ( $attr->has_trigger() ) {
  83             die sprintf(
  84                 'This class (%s) has an attribute (%s) with a trigger. Triggers cannot be compiled.',
  85                 $self->class(), $attr->name()
  86             );
  87         }
  88
  89         if ( $attr->has_initializer() ) {
  90             die sprintf(
  91                 'This class (%s) has an attribute (%s) with an initializer. Initializers cannot be compiled.',
  92                 $self->class(), $attr->name()
  93             );
  94         }
  95
  96         if ( $attr->has_type_constraint()
  97             && !$attr->type_constraint()->can_be_inlined() ) {
  98
  99             die sprintf(
 100                 'This class (%s) has an attribute (%s) with a type that cannot be inlined (%s)..',
 101                 $self->class(), $attr->name(),
 102                 $attr->type_constraint()->name()
 103             );
 104         }
 105     }
 106 }
 107
 108 sub _modify_class_content {
 109     my $self = shift;
 110
 111     $self->_maybe_rename_class();
 112     $self->_fixup_line_numbers();
 113     $self->_do_not_use_moose();
 114     $self->_inline_parents();
 115     $self->_load_required_modules();
 116
 117     return;
 118 }
 119
 120 sub _maybe_rename_class {
 121     my $self = shift;
 122
 123     return unless $self->_has_rename_to();
 124
 125     $self->_insert_code(
 126         $self->_package_statement(),
 127         'package ' . $self->rename_to() . ';'
 128     );
 129
 130     $self->_package_statement()->remove();
 131
 132     $self->_clear_package_statement();
 133
 134     return;
 135 }
 136
 137 sub _fixup_line_numbers {
 138     my $self = shift;
 139
 140     my $code = "#line 3\n";
 141
 142     $self->_insert_code(
 143         $self->_package_statement()->snext_sibling(),
 144         $code,
 145         'before',
 146     );
 147
 148     return;
 149 }
 150
 151 sub _do_not_use_moose {
 152     my $self = shift;
 153
 154     my $use_nodes = $self->_ppi_document()->find(
 155         sub {
 156             my $node = $_[1];
 157             return undef
 158                 if $node->isa('PPI::Statement')
 159                     && !$node->isa('PPI::Statement::Include');
 160             return undef if $node->isa('PPI::Structure');
 161             return 1
 162                 if $node->isa('PPI::Statement::Include')
 163                     && $node->module() =~ /^Moose/;
 164             return 0;
 165         }
 166     );
 167
 168     for my $node ( @{$use_nodes} ) {
 169         my $replacement_code .=
 170             defined $node->module_version()
 171             ? join(
 172             q{ },
 173             'use', $node->module(), $node->module_version(), '()', ';',
 174             )
 175             : '# ' . $node->content();
 176
 177         $self->_insert_code(
 178             $node,
 179             $replacement_code,
 180         );
 181
 182         $node->remove();
 183     }
 184
 185     return;
 186 }
 187
 188 sub _inline_parents {
 189     my $self = shift;
 190
 191     my @supers = $self->_class_meta()->superclasses();
 192     return unless @supers;
 193
 194     my $code = 'use parent ';
 195     $code .= join ', ', map { B::perlstring($_) } @supers;
 196     $code .= ";\n";
 197
 198     $self->_insert_code(
 199         $self->_package_statement(),
 200         $code,
 201     );
 202
 203     return;
 204 }
 205
 206 # XXX - replace this with something that looks at all the generated code for
 207 # calls of the form Foo::Bar::quux(...) - also don't load modules that are
 208 # already being used.
 209 sub _load_required_modules {
 210     my $self = shift;
 211
 212     my $code = join q{},
 213         map { "use $_ ();\n" }
 214         qw( Carp Moose::Error::Util Scalar::Util );
 215     $code .= "use MooseX::Compiler::FakeMoose;\n";
 216
 217     $self->_insert_code(
 218         $self->_package_statement(),
 219         $code,
 220     );
 221
 222     return;
 223 }
 224
 225 sub _insert_code {
 226     my $self      = shift;
 227     my $statement = shift;
 228     my $code      = shift;
 229     my $before    = shift;
 230
 231     my $method = $before ? 'insert_before' : 'insert_after';
 232     $statement->$method( $_->clone() )
 233         for PPI::Document->new( \$code )->children();
 234
 235     return;
 236 }
 237
 238 sub _inline_roles {
 239     return;
 240 }
 241
 242 sub _inline_constructor {
 243     my $self = shift;
 244
 245     my $environment = $self->_class_meta()->_eval_environment();
 246
 247     # This should go away in the next major release of Moose (I hope).
 248     delete $environment->{'$meta'};
 249
 250     # In the future, we need to work with Specio, which should make this
 251     # simpler (I hope).
 252     delete $environment->{'@type_constraint_bodies'};
 253
 254     my $body = join "\n", $self->_class_meta()->_inline_new_object();
 255     if ( $body =~ /\$meta/ ) {
 256         die
 257             'Cannot compile a class with a constructor that refers to the $meta object';
 258     }
 259
 260     my @defs = @{ ${ $environment->{'$defaults'} } };
 261     $environment->{'$defaults'} = \(
 262         [
 263             map { ref $defs[$_] ? '$___attributes[' . $_ . ']' : $defs[$_] }
 264                 0 .. $#defs
 265         ]
 266     );
 267
 268     my $constructor = join "\n", (
 269         '{',
 270         (
 271             map {
 272                 $self->_serialize_assignment( $_, $environment->{$_} ) . ';'
 273                 }
 274                 keys %{$environment}
 275         ),
 276         'sub new {',
 277         $body,
 278         '}',
 279         '}',
 280     );
 281
 282     $constructor .= "\n\n";
 283
 284     $self->_insert_before_end($constructor);
 285
 286     return;
 287 }
 288
 289 sub _inline_attributes {
 290     my $self = shift;
 291
 292     my $code;
 293     for my $attr ( $self->_class_meta()->get_all_attributes() ) {
 294         for my $method ( $attr->associated_methods() ) {
 295             # This is super gross, there really should be some sort of generic
 296             # "inlinable_method" thing
 297             my $generator_method = join "_" => (
 298                 '_generate',
 299                 $self->accessor_type,
 300                 'method_inline',
 301             );
 302
 303             $code .= $method->$generator_method();
 304         }
 305     }
 306
 307     $self->_insert_before_end($code);
 308
 309     return;
 310 }
 311
 312 sub _serialize_assignment {
 313     my $self  = shift;
 314     my $name  = shift;
 315     my $value = shift;
 316
 317     local $Data::Dumper::Terse     = 1;
 318     local $Data::Dumper::Indent    = 1;
 319     local $Data::Dumper::Useqq     = 1;
 320     local $Data::Dumper::Deparse   = 1;
 321     local $Data::Dumper::Quotekeys = 0;
 322     local $Data::Dumper::Sortkeys  = 1;
 323
 324     return
 325           "my $name = "
 326         . substr( $name, 0, 1 ) . '{ '
 327         . Data::Dumper->Dump( [$value] ) . ' }';
 328 }
 329
 330 sub _insert_before_end {
 331     my $self = shift;
 332     my $code = shift;
 333
 334     $self->_insert_code(
 335         $self->_end_node(),
 336         $code,
 337         'before',
 338     );
 339
 340     return;
 341 }
 342
 343 sub _build_ppi_document {
 344     my $self = shift;
 345
 346     my $pm_file       = module_notional_filename( $self->class() );
 347     my $path_to_class = $INC{$pm_file}
 348         or die "Cannot find $pm_file in %INC!";
 349
 350     return PPI::Document->new( $path_to_class->stringify() )
 351         or die PPI::Document->errstr();
 352 }
 353
 354 sub _build_package_statement {
 355     my $self = shift;
 356
 357     my $package_stmt = $self->_ppi_document()->find_first(
 358         sub {
 359             my $node = $_[1];
 360             return 1 if $_[1]->isa('PPI::Statement::Package');
 361             return 0;
 362         }
 363     );
 364
 365     die 'Cannot find a package statement in this code'
 366         unless $package_stmt;
 367
 368     return $package_stmt;
 369 }
 370
 371 sub _build_end_node {
 372     my $self = shift;
 373
 374     my $end_node = $self->_ppi_document()->find_first(
 375         sub {
 376             my $node = $_[1];
 377
 378             return 1
 379                 if $node->isa('PPI::Statement') && $node->content() =~ /^1;/;
 380             return 0;
 381         }
 382     );
 383
 384     die 'Cannot find the end of the class (looking for a line match /^1;/)'
 385         unless $end_node;
 386
 387     return $end_node;
 388 }
 389
 390 __PACKAGE__->meta()->make_immutable();
 391
 392 1;