From: Dave Rolsky <autarch@urth.org>
Date: Sun, 20 May 2012 21:56:06 +0000 (-0500)
Subject: Added code to fixup line numbers, inline constructor, and load modules that construct... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f56affb648486c4a45e35a042f8a8281394f1ddc;p=gitmo%2FMooseX-Compiler.git

Added code to fixup line numbers, inline constructor, and load modules that constructor needs
---

diff --git a/lib/MooseX/Compiler.pm b/lib/MooseX/Compiler.pm
index 5b73429..6306046 100644
--- a/lib/MooseX/Compiler.pm
+++ b/lib/MooseX/Compiler.pm
@@ -3,6 +3,7 @@ package MooseX::Compiler;
 use strict;
 use warnings;
 
+use B;
 use Module::Runtime qw( module_notional_filename );
 use PPI::Document;
 use Scalar::Util qw( blessed );
@@ -30,29 +31,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 +110,110 @@ 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;
 }
 
-sub _inlined_attribute_code {
-    return q{};
+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 _inline_roles {
+    return;
+}
+
+sub _inline_constructor {
+    my $self = shift;
+
+    my $constructor = join "\n",
+        (
+        'sub new {',
+        $self->_class_meta()->_inline_new_object(),
+        '}'
+        );
+
+    $constructor .= "\n\n";
+
+    $self->_insert_before_end($constructor);
+
+    return;
+}
+
+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();
diff --git a/t/constructor.t b/t/constructor.t
new file mode 100644
index 0000000..11a25cf
--- /dev/null
+++ b/t/constructor.t
@@ -0,0 +1,41 @@
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Test::MooseX::Compiler qw( save_fragment );
+use Test::More 0.88;
+
+use MooseX::Compiler;
+
+{
+    my $code = <<'EOF';
+use Moose;
+
+sub foo { 42 }
+EOF
+
+    my $class = 'Test::Class1';
+    save_fragment( $class, $code );
+
+    my $compiler = MooseX::Compiler->new(
+        class => $class,
+    );
+
+    my $compiled = $compiler->compile_class();
+    like(
+        $compiled,
+        qr/sub new {.+\n}\n/s,
+        'compiled code has a constructor'
+    );
+
+    for my $module (qw( Scalar::Util Moose::Error::Util Carp )) {
+        like(
+            $compiled,
+            qr/^use \Q$module\E \(\);/m,
+            "compiled code loads $module"
+        );
+    }
+}
+
+done_testing();
diff --git a/t/fixup-line-numbers.t b/t/fixup-line-numbers.t
new file mode 100644
index 0000000..16deefd
--- /dev/null
+++ b/t/fixup-line-numbers.t
@@ -0,0 +1,65 @@
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Test::Requires {
+    'IPC::Run3' => 0,
+};
+
+use Test::MooseX::Compiler qw( save_class );
+use Test::More 0.88;
+
+use IPC::Run3 qw( run3 );
+
+use MooseX::Compiler;
+
+{
+    my $code = <<'EOF';
+package Test::Class1;
+
+use strict;
+use warnings;
+
+use Moose;
+
+# should be line 9 below
+sub line { return __LINE__ }
+
+1;
+EOF
+
+    my $class = 'Test::Class1';
+    save_class( $class, $code );
+
+    my $compiler = MooseX::Compiler->new(
+        class => $class,
+    );
+
+    my $compiled = $compiler->compile_class();
+
+    my $output;
+    my $error;
+
+    # We need to compile the code in a fresh process to see if the line
+    # numbers are correct.
+    run3(
+        [
+            $^X, '-e',
+            $compiled . "\npackage main;\nprint Test::Class1->line();"
+        ],
+        \undef,
+        \$output,
+        \$error,
+    );
+
+    die $error if defined $error && length $error;
+
+    is(
+        $output,
+        9,
+        'compilation does not break line numbers'
+    );
+}
+
+done_testing();
diff --git a/t/lib/Test/MooseX/Compiler.pm b/t/lib/Test/MooseX/Compiler.pm
index 665a512..e6cfb89 100644
--- a/t/lib/Test/MooseX/Compiler.pm
+++ b/t/lib/Test/MooseX/Compiler.pm
@@ -11,11 +11,12 @@ use Path::Class qw( dir );
 
 our @EXPORT_OK = qw(
     save_class
+    save_fragment
 );
 
 my $Dir = dir( tempdir( CLEANUP => 1 ) );
 
-sub save_class {
+sub save_fragment {
     my $class = shift;
     my $code  = shift;
 
@@ -30,9 +31,16 @@ $code
 1;
 EOF
 
+    save_class($class, $full_code);
+}
+
+sub save_class {
+    my $class = shift;
+    my $code  = shift;
+
     {
         local $@;
-        eval $full_code;
+        eval $code;
         die $@ if $@;
     }
 
@@ -41,7 +49,7 @@ EOF
     $path->dir()->mkpath( 0, 0755 );
 
     open my $fh, '>', $path;
-    print {$fh} $full_code;
+    print {$fh} $code;
     close $fh;
 
     $INC{$pm_file} = $path;
diff --git a/t/remove-use-moose.t b/t/remove-use-moose.t
index f095a97..ca896be 100644
--- a/t/remove-use-moose.t
+++ b/t/remove-use-moose.t
@@ -7,7 +7,7 @@ use Test::Requires {
     'MooseX::StrictConstructor' => '0.01',
 };
 
-use Test::MooseX::Compiler qw( save_class );
+use Test::MooseX::Compiler qw( save_fragment );
 use Test::More 0.88;
 
 use MooseX::Compiler;
@@ -20,7 +20,7 @@ sub foo { 42 }
 EOF
 
     my $class = 'Test::Class1';
-    save_class( $class, $code );
+    save_fragment( $class, $code );
 
     my $compiler = MooseX::Compiler->new(
         class => $class,
@@ -51,7 +51,7 @@ sub foo { 42 }
 EOF
 
     my $class = 'Test::Class2';
-    save_class( $class, $code );
+    save_fragment( $class, $code );
 
     my $compiler = MooseX::Compiler->new(
         class => $class,
@@ -81,7 +81,7 @@ sub foo { 42 }
 EOF
 
     my $class = 'Test::Class3';
-    save_class( $class, $code );
+    save_fragment( $class, $code );
 
     my $compiler = MooseX::Compiler->new(
         class => $class,
@@ -123,7 +123,7 @@ sub foo { 42 }
 EOF
 
     my $class = 'Test::Class4';
-    save_class( $class, $code );
+    save_fragment( $class, $code );
 
     my $compiler = MooseX::Compiler->new(
         class => $class,