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',
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;
+ $self->_sanity_check_class();
$self->_modify_class_content();
$self->_inline_roles();
$self->_inline_constructor();
return $self->_ppi_document()->content();
}
+sub _sanity_check_class {
+ my $self = shift;
+
+ 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()
+ );
+ }
+
+ 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() ) {
+
+ 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();
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->_package_statement()->snext_sibling()->insert_before( $_->clone() )
- for PPI::Document->new( \$code )->children();
+
+ $self->_insert_code(
+ $self->_package_statement()->snext_sibling(),
+ $code,
+ 'before',
+ );
return;
}
)
: '# ' . $node->content();
- $node->insert_before( $_->clone() )
- for PPI::Document->new( \$replacement_code )->children();
+ $self->_insert_code(
+ $node,
+ $replacement_code,
+ );
+
$node->remove();
}
$code .= join ', ', map { B::perlstring($_) } @supers;
$code .= ";\n";
- $self->_package_statement()->insert_after( $_->clone() )
- for PPI::Document->new( \$code )->children();
+ $self->_insert_code(
+ $self->_package_statement(),
+ $code,
+ );
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";
+ 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,
+ );
- $self->_package_statement()->insert_after( $_->clone() )
+ 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_constructor {
my $self = shift;
- my $constructor = join "\n",
+ 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 {',
- $self->_class_meta()->_inline_new_object(),
- '}'
- );
+ $body,
+ '}',
+ '}',
+ );
$constructor .= "\n\n";
}
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;
- my $end_node = $self->_ppi_document()->find_first(
- sub {
- my $node = $_[1];
-
- return 1
- if $node->isa('PPI::Statement') && $node->content() =~ /^1;/;
- return 0;
- }
+ $self->_insert_code(
+ $self->_end_node(),
+ $code,
+ 'before',
);
- 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;
}
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();
1;
projects / gitmo/MooseX-Compiler.git / blobdiff