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');
29 isa => 'Moose::Meta::Class',
32 default => sub { $_[0]->class()->meta() },
35 has _ppi_document => (
37 isa => 'PPI::Document',
40 builder => '_build_ppi_document',
43 has _package_statement => (
45 isa => 'PPI::Statement::Package',
48 builder => '_build_package_statement',
54 $self->_modify_class_content();
55 $self->_inline_roles();
56 $self->_inline_constructor();
57 $self->_inline_attributes();
59 return $self->_ppi_document()->content();
62 sub _modify_class_content {
65 $self->_fixup_line_numbers();
66 $self->_do_not_use_moose();
67 $self->_inline_parents();
68 $self->_load_required_modules();
73 sub _fixup_line_numbers {
76 my $code = "#line 3\n";
77 $self->_package_statement()->snext_sibling()->insert_before( $_->clone() )
78 for PPI::Document->new( \$code )->children();
83 sub _do_not_use_moose {
86 my $use_nodes = $self->_ppi_document()->find(
90 if $node->isa('PPI::Statement')
91 && !$node->isa('PPI::Statement::Include');
92 return undef if $node->isa('PPI::Structure');
94 if $node->isa('PPI::Statement::Include')
95 && $node->module() =~ /^Moose/;
100 for my $node ( @{$use_nodes} ) {
101 my $replacement_code .=
102 defined $node->module_version()
105 'use', $node->module(), $node->module_version(), '()', ';',
107 : '# ' . $node->content();
109 $node->insert_before( $_->clone() )
110 for PPI::Document->new( \$replacement_code )->children();
117 sub _inline_parents {
120 my @supers = $self->_class_meta()->superclasses();
121 return unless @supers;
123 my $code = 'use parent ';
124 $code .= join ', ', map { B::perlstring($_) } @supers;
127 $self->_package_statement()->insert_after( $_->clone() )
128 for PPI::Document->new( \$code )->children();
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 {
139 my $code = "use Scalar::Util ();\nuse Moose::Error::Util ();\nuse Carp ();\n";
141 $self->_package_statement()->insert_after( $_->clone() )
142 for PPI::Document->new( \$code )->children();
151 sub _inline_constructor {
154 my $environment = $self->_class_meta()->_eval_environment();
155 delete $environment->{'$meta'};
156 delete $environment->{'@type_constraint_bodies'};
158 if ( grep { defined } @{ ${ $environment->{'$triggers'} } || [] } ) {
159 die 'Cannot compile a class with triggers for attributes';
162 my $body = join "\n", $self->_class_meta()->_inline_new_object();
163 if ( $body =~ /\$meta/ ) {
165 'Cannot compile a class with a constructor that refers to the $meta object';
168 my @defs = @{ ${ $environment->{'$defaults'} } };
169 $environment->{'$defaults'} = \(
171 map { ref $defs[$_] ? '$___attributes[' . $_ . ']' : $defs[$_] }
176 my $constructor = join "\n", (
180 $self->_serialize_assignment( $_, $environment->{$_} ) . ';'
190 $constructor .= "\n\n";
192 $self->_insert_before_end($constructor);
197 sub _serialize_assignment {
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;
211 . substr( $name, 0, 1 ) . '{ '
212 . Data::Dumper->Dump( [$value] ) . ' }';
215 sub _inline_attributes {
219 sub _insert_before_end {
223 my $end_node = $self->_ppi_document()->find_first(
228 if $node->isa('PPI::Statement') && $node->content() =~ /^1;/;
233 die 'Cannot find the end of the class (looking for a line match /^1;/)'
236 $end_node->insert_before( $_->clone() )
237 for PPI::Document->new( \$code )->children();
242 sub _build_ppi_document {
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!";
249 return PPI::Document->new( $path_to_class->stringify() )
250 or die PPI::Document->errstr();
253 sub _build_package_statement {
256 my $package_stmt = $self->_ppi_document()->find_first(
259 return 1 if $_[1]->isa('PPI::Statement::Package');
264 die 'Cannot find a package statement in this code'
265 unless $package_stmt;
267 return $package_stmt;
270 __PACKAGE__->meta()->make_immutable();