X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FCompiler.pm;h=813c8163f36798fa0b6c33e4980eef8a80a1758f;hb=5405fa515104b7e8f57fb1b14def70c52e898f64;hp=5b73429e8e358f8f4899fac5e9824ecd0237bc2f;hpb=9e60f0d8e2a14ca633e5f50ab34cebe6a9adc452;p=gitmo%2FMooseX-Compiler.git

diff --git a/lib/MooseX/Compiler.pm b/lib/MooseX/Compiler.pm
index 5b73429..813c816 100644
--- a/lib/MooseX/Compiler.pm
+++ b/lib/MooseX/Compiler.pm
@@ -3,6 +3,8 @@ package MooseX::Compiler;
 use strict;
 use warnings;
 
+use B;
+use Data::Dumper;
 use Module::Runtime qw( module_notional_filename );
 use PPI::Document;
 use Scalar::Util qw( blessed );
@@ -30,29 +32,58 @@ has _class_meta => (
     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
@@ -80,15 +111,160 @@ sub _adjusted_class_content {
         $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();