From: Dave Rolsky <autarch@urth.org>
Date: Fri, 14 Jun 2013 22:51:21 +0000 (-0500)
Subject: Commit this failed experiment
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5405fa515104b7e8f57fb1b14def70c52e898f64;hp=f56affb648486c4a45e35a042f8a8281394f1ddc;p=gitmo%2FMooseX-Compiler.git

Commit this failed experiment
---

diff --git a/lib/MooseX/Compiler.pm b/lib/MooseX/Compiler.pm
index 6306046..813c816 100644
--- a/lib/MooseX/Compiler.pm
+++ b/lib/MooseX/Compiler.pm
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 
 use B;
+use Data::Dumper;
 use Module::Runtime qw( module_notional_filename );
 use PPI::Document;
 use Scalar::Util qw( blessed );
@@ -129,6 +130,9 @@ sub _inline_parents {
     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;
 
@@ -147,12 +151,41 @@ sub _inline_roles {
 sub _inline_constructor {
     my $self = shift;
 
-    my $constructor = join "\n",
+    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 {',
-        $self->_class_meta()->_inline_new_object(),
-        '}'
-        );
+        $body,
+        '}',
+        '}',
+    );
 
     $constructor .= "\n\n";
 
@@ -161,6 +194,24 @@ sub _inline_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;
 }
diff --git a/t/constructor.t b/t/constructor.t
index 11a25cf..ffbc1f7 100644
--- a/t/constructor.t
+++ b/t/constructor.t
@@ -23,6 +23,7 @@ EOF
     );
 
     my $compiled = $compiler->compile_class();
+
     like(
         $compiled,
         qr/sub new {.+\n}\n/s,
@@ -38,4 +39,34 @@ EOF
     }
 }
 
+{
+    my $code = <<'EOF';
+use Moose;
+
+has a1 => (
+    is      => 'ro',
+    isa     => 'Int',
+    default => 42,
+);
+
+sub foo { 42 }
+EOF
+
+    my $class = 'Test::Class2';
+    save_fragment( $class, $code );
+
+    my $compiler = MooseX::Compiler->new(
+        class => $class,
+    );
+
+    my $compiled = $compiler->compile_class();
+warn $compiled;
+
+    like(
+        $compiled,
+        qr/sub new {.+\n}\n/s,
+        'compiled code has a constructor'
+    );
+}
+
 done_testing();