use strict;
use warnings;
+use B;
+use Data::Dumper;
use Module::Runtime qw( module_notional_filename );
use PPI::Document;
use Scalar::Util qw( blessed );
required => 1,
);
+has rename_to => (
+ is => 'ro',
+ isa => 'Str',
+ predicate => '_has_rename_to',
+);
+
has _class_meta => (
is => 'ro',
isa => 'Moose::Meta::Class',
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',
+ clearer => '_clear_package_statement',
+);
+
+has _end_node => (
+ is => 'ro',
+ isa => 'PPI::Statement',
+ init_arg => undef,
+ lazy => 1,
+ builder => '_build_end_node',
+);
+
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->_sanity_check_class();
+ $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 _sanity_check_class {
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!";
+ for my $attr ( $self->_class_meta()->get_all_attributes() ) {
+ if ( $attr->has_trigger() ) {
+ die sprintf(
+ 'This class (%s) has an attribute (%s) with a trigger. Triggers cannot be compiled.',
+ $self->class(), $attr->name()
+ );
+ }
- my $doc = PPI::Document->new( $path_to_class->stringify() )
- or die PPI::Document->errstr();
+ if ( $attr->has_initializer() ) {
+ die sprintf(
+ 'This class (%s) has an attribute (%s) with an initializer. Initializers cannot be compiled.',
+ $self->class(), $attr->name()
+ );
+ }
+
+ if ( $attr->has_type_constraint()
+ && !$attr->type_constraint()->can_be_inlined() ) {
- my $use_nodes = $doc->find(
+ die sprintf(
+ 'This class (%s) has an attribute (%s) with a type that cannot be inlined (%s)..',
+ $self->class(), $attr->name(),
+ $attr->type_constraint()->name()
+ );
+ }
+ }
+}
+
+sub _modify_class_content {
+ my $self = shift;
+
+ $self->_maybe_rename_class();
+ $self->_fixup_line_numbers();
+ $self->_do_not_use_moose();
+ $self->_inline_parents();
+ $self->_load_required_modules();
+
+ return;
+}
+
+sub _maybe_rename_class {
+ my $self = shift;
+
+ return unless $self->_has_rename_to();
+
+ $self->_insert_code(
+ $self->_package_statement(),
+ 'package ' . $self->rename_to() . ';'
+ );
+
+ $self->_package_statement()->remove();
+
+ $self->_clear_package_statement();
+
+ return;
+}
+
+sub _fixup_line_numbers {
+ my $self = shift;
+
+ my $code = "#line 3\n";
+
+ $self->_insert_code(
+ $self->_package_statement()->snext_sibling(),
+ $code,
+ 'before',
+ );
+
+ return;
+}
+
+sub _do_not_use_moose {
+ my $self = shift;
+
+ my $use_nodes = $self->_ppi_document()->find(
sub {
my $node = $_[1];
return undef
)
: '# ' . $node->content();
- $node->insert_before( $_->clone() )
- for PPI::Document->new( \$replacement_code )->children();
+ $self->_insert_code(
+ $node,
+ $replacement_code,
+ );
+
$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->_insert_code(
+ $self->_package_statement(),
+ $code,
+ );
+
+ return;
}
-sub _inlined_attribute_code {
- return q{};
+# 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 = join q{},
+ map { "use $_ ();\n" }
+ qw( Carp Moose::Error::Util Scalar::Util );
+ $code .= "use MooseX::Compiler::FakeMoose;\n";
+
+ $self->_insert_code(
+ $self->_package_statement(),
+ $code,
+ );
+
+ return;
+}
+
+sub _insert_code {
+ my $self = shift;
+ my $statement = shift;
+ my $code = shift;
+ my $before = shift;
+
+ my $method = $before ? 'insert_before' : 'insert_after';
+ $statement->$method( $_->clone() )
+ for PPI::Document->new( \$code )->children();
+
+ return;
+}
+
+sub _inline_roles {
+ return;
+}
+
+sub _inline_constructor {
+ my $self = shift;
+
+ my $environment = $self->_class_meta()->_eval_environment();
+
+ # This should go away in the next major release of Moose (I hope).
+ delete $environment->{'$meta'};
+
+ # In the future, we need to work with Specio, which should make this
+ # simpler (I hope).
+ delete $environment->{'@type_constraint_bodies'};
+
+ 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 _inline_attributes {
+ my $self = shift;
+
+ my $code;
+ for my $attr ( $self->_class_meta()->get_all_attributes() ) {
+ for my $method ( $attr->associated_methods() ) {
+ # This is super gross, there really should be some sort of generic
+ # "inlinable_method" thing
+ my $generator_method = join "_" => (
+ '_generate',
+ $self->accessor_type,
+ 'method_inline',
+ );
+
+ $code .= $method->$generator_method();
+ }
+ }
+
+ $self->_insert_before_end($code);
+
+ 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
+ "my $name = "
+ . substr( $name, 0, 1 ) . '{ '
+ . Data::Dumper->Dump( [$value] ) . ' }';
+}
+
+sub _insert_before_end {
+ my $self = shift;
+ my $code = shift;
+
+ $self->_insert_code(
+ $self->_end_node(),
+ $code,
+ 'before',
+ );
+
+ 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;
+}
+
+sub _build_end_node {
+ my $self = 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;
+
+ return $end_node;
}
__PACKAGE__->meta()->make_immutable();
projects / gitmo/MooseX-Compiler.git / blobdiff