1 package MooseX::Compiler;
8 use Module::Runtime qw( module_notional_filename );
10 use Scalar::Util qw( blessed );
13 use Moose::Util::TypeConstraints;
15 my $moose_class = subtype, as 'ClassName', where {
17 && blessed $_[0]->meta()
18 && $_[0]->meta()->isa('Moose::Meta::Class');
30 predicate => '_has_rename_to',
35 isa => 'Moose::Meta::Class',
38 default => sub { $_[0]->class()->meta() },
41 has _ppi_document => (
43 isa => 'PPI::Document',
46 builder => '_build_ppi_document',
49 has _package_statement => (
51 isa => 'PPI::Statement::Package',
54 builder => '_build_package_statement',
55 clearer => '_clear_package_statement',
60 isa => 'PPI::Statement',
63 builder => '_build_end_node',
69 $self->_sanity_check_class();
70 $self->_modify_class_content();
71 $self->_inline_roles();
72 $self->_inline_constructor();
73 $self->_inline_attributes();
75 return $self->_ppi_document()->content();
78 sub _sanity_check_class {
81 for my $attr ( $self->_class_meta()->get_all_attributes() ) {
82 if ( $attr->has_trigger() ) {
84 'This class (%s) has an attribute (%s) with a trigger. Triggers cannot be compiled.',
85 $self->class(), $attr->name()
89 if ( $attr->has_initializer() ) {
91 'This class (%s) has an attribute (%s) with an initializer. Initializers cannot be compiled.',
92 $self->class(), $attr->name()
96 if ( $attr->has_type_constraint()
97 && !$attr->type_constraint()->can_be_inlined() ) {
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()
108 sub _modify_class_content {
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();
120 sub _maybe_rename_class {
123 return unless $self->_has_rename_to();
126 $self->_package_statement(),
127 'package ' . $self->rename_to() . ';'
130 $self->_package_statement()->remove();
132 $self->_clear_package_statement();
137 sub _fixup_line_numbers {
140 my $code = "#line 3\n";
143 $self->_package_statement()->snext_sibling(),
151 sub _do_not_use_moose {
154 my $use_nodes = $self->_ppi_document()->find(
158 if $node->isa('PPI::Statement')
159 && !$node->isa('PPI::Statement::Include');
160 return undef if $node->isa('PPI::Structure');
162 if $node->isa('PPI::Statement::Include')
163 && $node->module() =~ /^Moose/;
168 for my $node ( @{$use_nodes} ) {
169 my $replacement_code .=
170 defined $node->module_version()
173 'use', $node->module(), $node->module_version(), '()', ';',
175 : '# ' . $node->content();
188 sub _inline_parents {
191 my @supers = $self->_class_meta()->superclasses();
192 return unless @supers;
194 my $code = 'use parent ';
195 $code .= join ', ', map { B::perlstring($_) } @supers;
199 $self->_package_statement(),
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 {
213 map { "use $_ ();\n" }
214 qw( Carp Moose::Error::Util Scalar::Util );
215 $code .= "use MooseX::Compiler::FakeMoose;\n";
218 $self->_package_statement(),
227 my $statement = shift;
231 my $method = $before ? 'insert_before' : 'insert_after';
232 $statement->$method( $_->clone() )
233 for PPI::Document->new( \$code )->children();
242 sub _inline_constructor {
245 my $environment = $self->_class_meta()->_eval_environment();
247 # This should go away in the next major release of Moose (I hope).
248 delete $environment->{'$meta'};
250 # In the future, we need to work with Specio, which should make this
252 delete $environment->{'@type_constraint_bodies'};
254 my $body = join "\n", $self->_class_meta()->_inline_new_object();
255 if ( $body =~ /\$meta/ ) {
257 'Cannot compile a class with a constructor that refers to the $meta object';
260 my @defs = @{ ${ $environment->{'$defaults'} } };
261 $environment->{'$defaults'} = \(
263 map { ref $defs[$_] ? '$___attributes[' . $_ . ']' : $defs[$_] }
268 my $constructor = join "\n", (
272 $self->_serialize_assignment( $_, $environment->{$_} ) . ';'
282 $constructor .= "\n\n";
284 $self->_insert_before_end($constructor);
289 sub _inline_attributes {
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 "_" => (
299 $self->accessor_type,
303 $code .= $method->$generator_method();
307 $self->_insert_before_end($code);
312 sub _serialize_assignment {
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;
326 . substr( $name, 0, 1 ) . '{ '
327 . Data::Dumper->Dump( [$value] ) . ' }';
330 sub _insert_before_end {
343 sub _build_ppi_document {
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!";
350 return PPI::Document->new( $path_to_class->stringify() )
351 or die PPI::Document->errstr();
354 sub _build_package_statement {
357 my $package_stmt = $self->_ppi_document()->find_first(
360 return 1 if $_[1]->isa('PPI::Statement::Package');
365 die 'Cannot find a package statement in this code'
366 unless $package_stmt;
368 return $package_stmt;
371 sub _build_end_node {
374 my $end_node = $self->_ppi_document()->find_first(
379 if $node->isa('PPI::Statement') && $node->content() =~ /^1;/;
384 die 'Cannot find the end of the class (looking for a line match /^1;/)'
390 __PACKAGE__->meta()->make_immutable();