lib/MooseX/Compiler.pm

   1 package MooseX::Compiler;
   2
   3 use strict;
   4 use warnings;
   5
   6 use B;
   7 use Module::Runtime qw( module_notional_filename );
   8 use PPI::Document;
   9 use Scalar::Util qw( blessed );
  10
  11 use Moose;
  12 use Moose::Util::TypeConstraints;
  13
  14 my $moose_class = subtype, as 'ClassName', where {
  15     $_[0]->can('meta')
  16         && blessed $_[0]->meta()
  17         && $_[0]->meta()->isa('Moose::Meta::Class');
  18 };
  19
  20 has class => (
  21     is       => 'ro',
  22     isa      => $moose_class,
  23     required => 1,
  24 );
  25
  26 has _class_meta => (
  27     is       => 'ro',
  28     isa      => 'Moose::Meta::Class',
  29     init_arg => undef,
  30     lazy     => 1,
  31     default  => sub { $_[0]->class()->meta() },
  32 );
  33
  34 has _ppi_document => (
  35     is       => 'ro',
  36     isa      => 'PPI::Document',
  37     init_arg => undef,
  38     lazy     => 1,
  39     builder  => '_build_ppi_document',
  40 );
  41
  42 has _package_statement => (
  43     is       => 'ro',
  44     isa      => 'PPI::Statement::Package',
  45     init_arg => undef,
  46     lazy     => 1,
  47     builder  => '_build_package_statement',
  48 );
  49
  50 sub compile_class {
  51     my $self = shift;
  52
  53     $self->_modify_class_content();
  54     $self->_inline_roles();
  55     $self->_inline_constructor();
  56     $self->_inline_attributes();
  57
  58     return $self->_ppi_document()->content();
  59 }
  60
  61 sub _modify_class_content {
  62     my $self = shift;
  63
  64     $self->_fixup_line_numbers();
  65     $self->_do_not_use_moose();
  66     $self->_inline_parents();
  67     $self->_load_required_modules();
  68
  69     return;
  70 }
  71
  72 sub _fixup_line_numbers {
  73     my $self = shift;
  74
  75     my $code = "#line 3\n";
  76     $self->_package_statement()->snext_sibling()->insert_before( $_->clone() )
  77         for PPI::Document->new( \$code )->children();
  78
  79     return;
  80 }
  81
  82 sub _do_not_use_moose {
  83     my $self = shift;
  84
  85     my $use_nodes = $self->_ppi_document()->find(
  86         sub {
  87             my $node = $_[1];
  88             return undef
  89                 if $node->isa('PPI::Statement')
  90                     && !$node->isa('PPI::Statement::Include');
  91             return undef if $node->isa('PPI::Structure');
  92             return 1
  93                 if $node->isa('PPI::Statement::Include')
  94                     && $node->module() =~ /^Moose/;
  95             return 0;
  96         }
  97     );
  98
  99     for my $node ( @{$use_nodes} ) {
 100         my $replacement_code .=
 101             defined $node->module_version()
 102             ? join(
 103             q{ },
 104             'use', $node->module(), $node->module_version(), '()', ';',
 105             )
 106             : '# ' . $node->content();
 107
 108         $node->insert_before( $_->clone() )
 109             for PPI::Document->new( \$replacement_code )->children();
 110         $node->remove();
 111     }
 112
 113     return;
 114 }
 115
 116 sub _inline_parents {
 117     my $self = shift;
 118
 119     my @supers = $self->_class_meta()->superclasses();
 120     return unless @supers;
 121
 122     my $code = 'use parent ';
 123     $code .= join ', ', map { B::perlstring($_) } @supers;
 124     $code .= ";\n";
 125
 126     $self->_package_statement()->insert_after( $_->clone() )
 127         for PPI::Document->new( \$code )->children();
 128
 129     return;
 130 }
 131
 132 sub _load_required_modules {
 133     my $self = shift;
 134
 135     my $code = "use Scalar::Util ();\nuse Moose::Error::Util ();\nuse Carp ();\n";
 136
 137     $self->_package_statement()->insert_after( $_->clone() )
 138         for PPI::Document->new( \$code )->children();
 139
 140     return;
 141 }
 142
 143 sub _inline_roles {
 144     return;
 145 }
 146
 147 sub _inline_constructor {
 148     my $self = shift;
 149
 150     my $constructor = join "\n",
 151         (
 152         'sub new {',
 153         $self->_class_meta()->_inline_new_object(),
 154         '}'
 155         );
 156
 157     $constructor .= "\n\n";
 158
 159     $self->_insert_before_end($constructor);
 160
 161     return;
 162 }
 163
 164 sub _inline_attributes {
 165     return;
 166 }
 167
 168 sub _insert_before_end {
 169     my $self = shift;
 170     my $code = shift;
 171
 172     my $end_node = $self->_ppi_document()->find_first(
 173         sub {
 174             my $node = $_[1];
 175
 176             return 1
 177                 if $node->isa('PPI::Statement') && $node->content() =~ /^1;/;
 178             return 0;
 179         }
 180     );
 181
 182     die 'Cannot find the end of the class (looking for a line match /^1;/)'
 183         unless $end_node;
 184
 185     $end_node->insert_before( $_->clone() )
 186         for PPI::Document->new( \$code )->children();
 187
 188     return;
 189 }
 190
 191 sub _build_ppi_document {
 192     my $self = shift;
 193
 194     my $pm_file       = module_notional_filename( $self->class() );
 195     my $path_to_class = $INC{$pm_file}
 196         or die "Cannot find $pm_file in %INC!";
 197
 198     return PPI::Document->new( $path_to_class->stringify() )
 199         or die PPI::Document->errstr();
 200 }
 201
 202 sub _build_package_statement {
 203     my $self = shift;
 204
 205     my $package_stmt = $self->_ppi_document()->find_first(
 206         sub {
 207             my $node = $_[1];
 208             return 1 if $_[1]->isa('PPI::Statement::Package');
 209             return 0;
 210         }
 211     );
 212
 213     die 'Cannot find a package statement in this code'
 214         unless $package_stmt;
 215
 216     return $package_stmt;
 217 }
 218
 219 __PACKAGE__->meta()->make_immutable();
 220
 221 1;