use strict;
use warnings;
+use B;
+use Data::Dumper;
use Module::Runtime qw( module_notional_filename );
use PPI::Document;
use Scalar::Util qw( blessed );
default => sub { $_[0]->class()->meta() },
);
+has _ppi_document => (
+ is => 'ro',
+ isa => 'PPI::Document',
+ init_arg => undef,
+ lazy => 1,
+ builder => '_build_ppi_document',
+);
+
+has _package_statement => (
+ is => 'ro',
+ isa => 'PPI::Statement::Package',
+ init_arg => undef,
+ lazy => 1,
+ builder => '_build_package_statement',
+);
+
sub compile_class {
- my $self = shift;
+ my $self = shift;
- my $code
- = join q{},
- $self->_adjusted_class_content(),
- $self->_adjusted_role_content(),
- $self->_inlined_attribute_code();
+ $self->_modify_class_content();
+ $self->_inline_roles();
+ $self->_inline_constructor();
+ $self->_inline_attributes();
- return $code;
+ return $self->_ppi_document()->content();
}
-sub _adjusted_class_content {
+sub _modify_class_content {
my $self = shift;
- my $pm_file = module_notional_filename( $self->class() );
- my $path_to_class = $INC{$pm_file}
- or die "Cannot find $pm_file in %INC!";
+ $self->_fixup_line_numbers();
+ $self->_do_not_use_moose();
+ $self->_inline_parents();
+ $self->_load_required_modules();
- my $doc = PPI::Document->new( $path_to_class->stringify() )
- or die PPI::Document->errstr();
+ return;
+}
+
+sub _fixup_line_numbers {
+ my $self = shift;
+
+ my $code = "#line 3\n";
+ $self->_package_statement()->snext_sibling()->insert_before( $_->clone() )
+ for PPI::Document->new( \$code )->children();
+
+ return;
+}
+
+sub _do_not_use_moose {
+ my $self = shift;
- my $use_nodes = $doc->find(
+ my $use_nodes = $self->_ppi_document()->find(
sub {
my $node = $_[1];
return undef
$node->remove();
}
- return $doc->content();
+ return;
}
-sub _adjusted_role_content {
- return q{};
+sub _inline_parents {
+ my $self = shift;
+
+ my @supers = $self->_class_meta()->superclasses();
+ return unless @supers;
+
+ my $code = 'use parent ';
+ $code .= join ', ', map { B::perlstring($_) } @supers;
+ $code .= ";\n";
+
+ $self->_package_statement()->insert_after( $_->clone() )
+ for PPI::Document->new( \$code )->children();
+
+ return;
+}
+
+# XXX - replace this with something that looks at all the generated code for
+# calls of the form Foo::Bar::quux(...) - also don't load modules that are
+# already being used.
+sub _load_required_modules {
+ my $self = shift;
+
+ my $code = "use Scalar::Util ();\nuse Moose::Error::Util ();\nuse Carp ();\n";
+
+ $self->_package_statement()->insert_after( $_->clone() )
+ for PPI::Document->new( \$code )->children();
+
+ return;
}
-sub _inlined_attribute_code {
- return q{};
+sub _inline_roles {
+ return;
+}
+
+sub _inline_constructor {
+ my $self = shift;
+
+ my $environment = $self->_class_meta()->_eval_environment();
+ delete $environment->{'$meta'};
+ delete $environment->{'@type_constraint_bodies'};
+
+ if ( grep { defined } @{ ${ $environment->{'$triggers'} } || [] } ) {
+ die 'Cannot compile a class with triggers for attributes';
+ }
+
+ my $body = join "\n", $self->_class_meta()->_inline_new_object();
+ if ( $body =~ /\$meta/ ) {
+ die
+ 'Cannot compile a class with a constructor that refers to the $meta object';
+ }
+
+ my @defs = @{ ${ $environment->{'$defaults'} } };
+ $environment->{'$defaults'} = \(
+ [
+ map { ref $defs[$_] ? '$___attributes[' . $_ . ']' : $defs[$_] }
+ 0 .. $#defs
+ ]
+ );
+
+ my $constructor = join "\n", (
+ '{',
+ (
+ map {
+ $self->_serialize_assignment( $_, $environment->{$_} ) . ';'
+ }
+ keys %{$environment}
+ ),
+ 'sub new {',
+ $body,
+ '}',
+ '}',
+ );
+
+ $constructor .= "\n\n";
+
+ $self->_insert_before_end($constructor);
+
+ return;
+}
+
+sub _serialize_assignment {
+ my $self = shift;
+ my $name = shift;
+ my $value = shift;
+
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Useqq = 1;
+ local $Data::Dumper::Deparse = 1;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Sortkeys = 1;
+
+ return
+ "$name = "
+ . substr( $name, 0, 1 ) . '{ '
+ . Data::Dumper->Dump( [$value] ) . ' }';
+}
+
+sub _inline_attributes {
+ return;
+}
+
+sub _insert_before_end {
+ my $self = shift;
+ my $code = shift;
+
+ my $end_node = $self->_ppi_document()->find_first(
+ sub {
+ my $node = $_[1];
+
+ return 1
+ if $node->isa('PPI::Statement') && $node->content() =~ /^1;/;
+ return 0;
+ }
+ );
+
+ die 'Cannot find the end of the class (looking for a line match /^1;/)'
+ unless $end_node;
+
+ $end_node->insert_before( $_->clone() )
+ for PPI::Document->new( \$code )->children();
+
+ return;
+}
+
+sub _build_ppi_document {
+ my $self = shift;
+
+ my $pm_file = module_notional_filename( $self->class() );
+ my $path_to_class = $INC{$pm_file}
+ or die "Cannot find $pm_file in %INC!";
+
+ return PPI::Document->new( $path_to_class->stringify() )
+ or die PPI::Document->errstr();
+}
+
+sub _build_package_statement {
+ my $self = shift;
+
+ my $package_stmt = $self->_ppi_document()->find_first(
+ sub {
+ my $node = $_[1];
+ return 1 if $_[1]->isa('PPI::Statement::Package');
+ return 0;
+ }
+ );
+
+ die 'Cannot find a package statement in this code'
+ unless $package_stmt;
+
+ return $package_stmt;
}
__PACKAGE__->meta()->make_immutable();