From: Jesse Luehrs Date: Thu, 11 Nov 2010 14:32:07 +0000 (-0600) Subject: push constructor generation back into Moose::Meta::Class X-Git-Tag: 1.9900~32 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e3225a0f6eb5e9fc6303a3f6109904b3ccfb2d86;p=gitmo%2FMoose.git push constructor generation back into Moose::Meta::Class --- diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 24acd83..4f46020 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -280,6 +280,254 @@ sub new_object { return $object; } +sub _generate_fallback_constructor { + my $self = shift; + my ($class) = @_; + return $class . '->Moose::Object::new(@_)' +} + +sub _inline_params { + my $self = shift; + my ($params, $class) = @_; + return ( + 'my ' . $params . ' = ', + $self->_inline_BUILDARGS($class, '@_'), + ';', + ); +} + +sub _inline_BUILDARGS { + my $self = shift; + my ($class, $args) = @_; + + my $buildargs = $self->find_method_by_name("BUILDARGS"); + + if ($args eq '@_' + && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) { + return ( + 'do {', + 'my $params;', + 'if (scalar @_ == 1) {', + 'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {', + $self->_inline_throw_error( + '"Single parameters to new() must be a HASH ref"', + 'data => $_[0]', + ) . ';', + '}', + '$params = { %{ $_[0] } };', + '}', + 'elsif (@_ % 2) {', + 'Carp::carp(', + '"The new() method for ' . $class . ' expects a ' + . 'hash reference or a key/value list. You passed an ' + . 'odd number of arguments"', + ');', + '$params = {@_, undef};', + '}', + 'else {', + '$params = {@_};', + '}', + '$params;', + '}', + ); + } + else { + return $class . '->BUILDARGS(' . $args . ')'; + } +} + +sub _inline_slot_initializer { + my $self = shift; + my ($attr, $index) = @_; + + my @source = ('## ' . $attr->name); + + push @source, $self->_inline_check_required_attr($attr); + + if (defined $attr->init_arg) { + push @source, + 'if (exists $params->{\'' . $attr->init_arg . '\'}) {', + $self->_inline_init_attr_from_constructor($attr, $index), + '}'; + if (my @default = $self->_inline_init_attr_from_default($attr, $index)) { + push @source, + 'else {', + @default, + '}'; + } + } + else { + if (my @default = $self->_inline_init_attr_from_default($attr, $index)) { + push @source, + '{', # _init_attr_from_default creates variables + @default, + '}'; + } + } + + return @source; +} + +sub _inline_check_required_attr { + my $self = shift; + my ($attr) = @_; + + return unless defined $attr->init_arg; + return unless $attr->can('is_required') && $attr->is_required; + return if $attr->has_default || $attr->has_builder; + + return ( + 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {', + $self->_inline_throw_error( + '"Attribute (' . quotemeta($attr->name) . ') is required"' + ) . ';', + '}', + ); +} + +sub _inline_init_attr_from_constructor { + my $self = shift; + my ($attr, $index) = @_; + + return ( + 'my $val = $params->{\'' . $attr->init_arg . '\'};', + $self->_inline_slot_assignment($attr, $index, '$val'), + ); +} + +sub _inline_init_attr_from_default { + my $self = shift; + my ($attr, $index) = @_; + + my $default = $self->_inline_default_value($attr, $index); + return unless $default; + + return ( + 'my $val = ' . $default . ';', + $self->_inline_slot_assignment($attr, $index, '$val'), + ); +} + +sub _inline_slot_assignment { + my $self = shift; + my ($attr, $index, $value) = @_; + + my @source; + + push @source, $self->_inline_type_constraint_and_coercion( + $attr, $index, $value, + ); + + if ($attr->has_initializer) { + push @source, ( + '$attrs->[' . $index . ']->set_initial_value(', + '$instance' . ',', + $value . ',', + ');' + ); + } + else { + push @source, ( + $attr->_inline_instance_set('$instance', $value) . ';', + ); + } + + return @source; +} + +sub _inline_type_constraint_and_coercion { + my $self = shift; + my ($attr, $index, $value) = @_; + + return unless $attr->can('has_type_constraint') + && $attr->has_type_constraint; + + my @source; + + if ($attr->should_coerce && $attr->type_constraint->has_coercion) { + push @source => $self->_inline_type_coercion( + '$type_constraints[' . $index . ']', + $value, + $value, + ); + } + + push @source => $self->_inline_type_constraint_check( + $attr, + '$type_constraint_bodies[' . $index . ']', + '$type_constraints[' . $index . ']', + $value, + ); + + return @source; +} + +sub _inline_type_coercion { + my $self = shift; + my ($tc_obj, $value, $return_value) = @_; + return $return_value . ' = ' . $tc_obj . '->coerce(' . $value . ');'; +} + +sub _inline_type_constraint_check { + my $self = shift; + my ($attr, $tc_body, $tc_obj, $value) = @_; + return ( + $self->_inline_throw_error( + '"Attribute (' . quotemeta($attr->name) . ') ' + . 'does not pass the type constraint because: " . ' + . $tc_obj . '->get_message(' . $value . ')' + ), + 'unless ' . $tc_body . '->(' . $value . ');' + ); +} + +sub _inline_extra_init { + my $self = shift; + return ( + $self->_inline_triggers, + $self->_inline_BUILDALL, + ); +} + +sub _inline_triggers { + my $self = shift; + my @trigger_calls; + + my @attrs = $self->get_all_attributes; + for my $i (0 .. $#attrs) { + my $attr = $attrs[$i]; + + next unless $attr->can('has_trigger') && $attr->has_trigger; + + my $init_arg = $attr->init_arg; + next unless defined $init_arg; + + push @trigger_calls, + 'if (exists $params->{\'' . $init_arg . '\'}) {', + '$attrs->[' . $i . ']->trigger->(', + '$instance,', + $attr->_inline_instance_get('$instance') . ',', + ');', + '}'; + } + + return @trigger_calls; +} + +sub _inline_BUILDALL { + my $self = shift; + + my @methods = reverse $self->find_all_methods_by_name('BUILD'); + my @BUILD_calls; + + foreach my $method (@methods) { + push @BUILD_calls, + '$instance->' . $method->{class} . '::BUILD($params);'; + } + + return @BUILD_calls; +} + sub superclasses { my $self = shift; my $supers = Data::OptList::mkopt(\@_); @@ -478,6 +726,11 @@ sub throw_error { $self->raise_error($self->create_error(@args)); } +sub _inline_throw_error { + my ( $self, $msg, $args ) = @_; + "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard +} + sub raise_error { my ( $self, @args ) = @_; die @args; diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm index ed3c1ab..065482f 100644 --- a/lib/Moose/Meta/Method/Constructor.pm +++ b/lib/Moose/Meta/Method/Constructor.pm @@ -85,307 +85,6 @@ sub _eval_environment { }; } -sub _generate_constructor_method_inline { - my $self = shift; - # TODO: - # the %options should also include a both - # a call 'initializer' and call 'SUPER::' - # options, which should cover approx 90% - # of the possible use cases (even if it - # requires some adaption on the part of - # the author, after all, nothing is free) - - my @source = ( - 'sub {', - 'my $_instance = shift;', - 'my $class = Scalar::Util::blessed($_instance) || $_instance;', - 'if ($class ne \'' . $self->associated_metaclass->name . '\') {', - 'return ' . $self->_generate_fallback_constructor('$class') . ';', - '}', - $self->_generate_params('$params', '$class'), - $self->_generate_instance('$instance', '$class'), - $self->_generate_slot_initializers, - $self->_generate_triggers, - $self->_generate_BUILDALL, - 'return $instance;', - '}' - ); - warn join("\n", @source) if $self->options->{debug}; - - return try { - $self->_compile_code(\@source); - } - catch { - my $source = join("\n", @source); - $self->throw_error( - "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$_", - error => $_, - data => $source, - ); - }; -} - -sub _generate_fallback_constructor { - my $self = shift; - my ($class_var) = @_; - return $class_var . '->Moose::Object::new(@_)' -} - -sub _generate_params { - my $self = shift; - my ($var, $class_var) = @_; - return ( - 'my ' . $var . ' = ', - $self->_generate_BUILDARGS($class_var, '@_'), - ';', - ); -} - -sub _generate_instance { - my $self = shift; - my ($var, $class_var) = @_; - my $meta = $self->associated_metaclass; - - return ( - 'my ' . $var . ' = ', - $meta->inline_create_instance($class_var) . ';', - ); -} - -sub _generate_slot_initializers { - my $self = shift; - return map { $self->_generate_slot_initializer($_) } - 0 .. (@{$self->_attributes} - 1); -} - -sub _generate_BUILDARGS { - my $self = shift; - my ($class, $args) = @_; - - my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS"); - - if ($args eq '@_' - && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) { - - return ( - 'do {', - 'my $params;', - 'if (scalar @_ == 1) {', - 'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {', - $self->_inline_throw_error( - '"Single parameters to new() must be a HASH ref"', - 'data => $_[0]', - ) . ';', - '}', - '$params = { %{ $_[0] } };', - '}', - 'elsif (@_ % 2) {', - 'Carp::carp(', - '"The new() method for ' . $class . ' expects a ' - . 'hash reference or a key/value list. You passed an ' - . 'odd number of arguments"', - ');', - '$params = {@_, undef};', - '}', - 'else {', - '$params = {@_};', - '}', - '$params;', - '}', - ); - } - else { - return $class . '->BUILDARGS(' . $args . ')'; - } -} - -sub _generate_BUILDALL { - my $self = shift; - - my @methods = reverse $self->associated_metaclass->find_all_methods_by_name('BUILD'); - my @BUILD_calls; - - foreach my $method (@methods) { - push @BUILD_calls, - '$instance->' . $method->{class} . '::BUILD($params);'; - } - - return @BUILD_calls; -} - -sub _generate_triggers { - my $self = shift; - my @trigger_calls; - - for my $i (0 .. $#{ $self->_attributes }) { - my $attr = $self->_attributes->[$i]; - - next unless $attr->can('has_trigger') && $attr->has_trigger; - - my $init_arg = $attr->init_arg; - next unless defined $init_arg; - - push @trigger_calls, - 'if (exists $params->{\'' . $init_arg . '\'}) {', - '$attrs->[' . $i . ']->trigger->(', - '$instance,', - $attr->_inline_instance_get('$instance') . ',', - ');', - '}'; - } - - return @trigger_calls; -} - -sub _generate_slot_initializer { - my $self = shift; - my ($index) = @_; - - my $attr = $self->_attributes->[$index]; - - my @source = ('## ' . $attr->name); - - push @source, $self->_check_required_attr($attr); - - if (defined $attr->init_arg) { - push @source, - 'if (exists $params->{\'' . $attr->init_arg . '\'}) {', - $self->_init_attr_from_constructor($attr, $index), - '}'; - if (my @default = $self->_init_attr_from_default($attr, $index)) { - push @source, - 'else {', - @default, - '}'; - } - } - else { - if (my @default = $self->_init_attr_from_default($attr, $index)) { - push @source, - '{', # _init_attr_from_default creates variables - @default, - '}'; - } - } - - return @source; -} - -sub _check_required_attr { - my $self = shift; - my ($attr) = @_; - - return unless defined $attr->init_arg; - return unless $attr->can('is_required') && $attr->is_required; - return if $attr->has_default || $attr->has_builder; - - return ( - 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {', - $self->_inline_throw_error( - '"Attribute (' . quotemeta($attr->name) . ') is required"' - ) . ';', - '}', - ); -} - -sub _init_attr_from_constructor { - my $self = shift; - my ($attr, $index) = @_; - - return ( - 'my $val = $params->{\'' . $attr->init_arg . '\'};', - $self->_generate_slot_assignment($attr, $index, '$val'), - ); -} - -sub _init_attr_from_default { - my $self = shift; - my ($attr, $index) = @_; - - my $default = $self->_generate_default_value($attr, $index); - return unless $default; - - return ( - 'my $val = ' . $default . ';', - $self->_generate_slot_assignment($attr, $index, '$val'), - ); -} - -sub _generate_slot_assignment { - my $self = shift; - my ($attr, $index, $value) = @_; - - my @source; - - if ($self->can('_generate_type_constraint_and_coercion')) { - push @source, $self->_generate_type_constraint_and_coercion( - $attr, $index, $value, - ); - } - - if ($attr->has_initializer) { - push @source, ( - '$attrs->[' . $index . ']->set_initial_value(', - '$instance' . ',', - $value . ',', - ');' - ); - } - else { - push @source, ( - $attr->_inline_instance_set('$instance', $value) . ';', - ); - } - - return @source; -} - -sub _generate_type_constraint_and_coercion { - my $self = shift; - my ($attr, $index, $value) = @_; - - return unless $attr->can('has_type_constraint') - && $attr->has_type_constraint; - - my @source; - - if ($attr->should_coerce && $attr->type_constraint->has_coercion) { - push @source => $self->_generate_type_coercion( - '$type_constraints[' . $index . ']', - $value, - $value, - ); - } - - push @source => $self->_generate_type_constraint_check( - $attr, - '$type_constraint_bodies[' . $index . ']', - '$type_constraints[' . $index . ']', - $value, - ); - - return @source; -} - -sub _generate_type_coercion { - my $self = shift; - my ($tc_obj, $value, $return_value) = @_; - return $return_value . ' = ' . $tc_obj . '->coerce(' . $value . ');'; -} - -sub _generate_type_constraint_check { - my $self = shift; - my ($attr, $tc_body, $tc_obj, $value) = @_; - return ( - $self->_inline_throw_error( - '"Attribute (' . quotemeta($attr->name) . ') ' - . 'does not pass the type constraint because: " . ' - . $tc_obj . '->get_message(' . $value . ')' - ), - 'unless ' . $tc_body . '->(' . $value . ');' - ); -} - 1; __END__ diff --git a/t/050_metaclasses/052_metaclass_compat.t b/t/050_metaclasses/052_metaclass_compat.t index 675daf4..a16bee7 100644 --- a/t/050_metaclasses/052_metaclass_compat.t +++ b/t/050_metaclasses/052_metaclass_compat.t @@ -7,10 +7,10 @@ use Test::Fatal; our $called = 0; { - package Foo::Trait::Constructor; + package Foo::Trait::Class; use Moose::Role; - around _generate_BUILDALL => sub { + around _inline_BUILDALL => sub { my $orig = shift; my $self = shift; return ( @@ -26,7 +26,7 @@ our $called = 0; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { - constructor => ['Foo::Trait::Constructor'], + class => ['Foo::Trait::Class'], } ); } @@ -38,8 +38,8 @@ Foo->meta->make_immutable; Foo->new; is($called, 1, "inlined constructor has trait modifications"); -ok(Foo->meta->constructor_class->meta->does_role('Foo::Trait::Constructor'), - "class has correct constructor traits"); +ok(Foo->meta->meta->does_role('Foo::Trait::Class'), + "class has correct traits"); { package Foo::Sub; @@ -55,11 +55,11 @@ is($called, 0, "no calls before inlining"); Foo::Sub->meta->make_immutable; Foo::Sub->new; -is($called, 1, "inherits constructor trait properly"); +is($called, 1, "inherits trait properly"); -ok(Foo::Sub->meta->constructor_class->meta->can('does_role') -&& Foo::Sub->meta->constructor_class->meta->does_role('Foo::Trait::Constructor'), - "subclass inherits constructor traits"); +ok(Foo::Sub->meta->meta->can('does_role') +&& Foo::Sub->meta->meta->does_role('Foo::Trait::Class'), + "subclass inherits traits"); { package Foo2::Role;