From: Dave Rolsky 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;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();