Commit this failed experiment

[gitmo/MooseX-Compiler.git] / lib / MooseX / Compiler.pm

diff --git a/lib/MooseX/Compiler.pm b/lib/MooseX/Compiler.pm
index 6306046..813c816 100644 (file)
--- 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;
 }