From: Guillermo Roditi Date: Tue, 13 Nov 2007 00:05:22 +0000 (+0000) Subject: inlined constructor correction for lazy_build and new test X-Git-Tag: 0_27~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7a5b07b38325c07df0ff93711ded913a050c44b2;p=gitmo%2FMoose.git inlined constructor correction for lazy_build and new test --- diff --git a/Changes b/Changes index 41e61b1..0c70805 100644 --- a/Changes +++ b/Changes @@ -10,6 +10,9 @@ Revision history for Perl extension Moose - Fix inline methods to work with corrected predicate behavior (groditi) + * Moose::Meta::Method::Constructor + - Added support for lazy_build option (groditi) + * t/ - tests for builder and lazy_build (groditi) diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm index 9da35cf..ae234ea 100644 --- a/lib/Moose/Meta/Method/Constructor.pm +++ b/lib/Moose/Meta/Method/Constructor.pm @@ -15,32 +15,32 @@ use base 'Moose::Meta::Method'; sub new { my $class = shift; my %options = @_; - + (exists $options{options} && ref $options{options} eq 'HASH') - || confess "You must pass a hash of options"; - + || confess "You must pass a hash of options"; + my $self = bless { # from our superclass '&!body' => undef, # specific to this subclass '%!options' => $options{options}, '$!meta_instance' => $options{metaclass}->get_meta_instance, - '@!attributes' => [ $options{metaclass}->compute_all_applicable_attributes ], + '@!attributes' => [ $options{metaclass}->compute_all_applicable_attributes ], # ... '$!associated_metaclass' => $options{metaclass}, } => $class; - # we don't want this creating - # a cycle in the code, if not + # we don't want this creating + # a cycle in the code, if not # needed - weaken($self->{'$!associated_metaclass'}); + weaken($self->{'$!associated_metaclass'}); $self->intialize_body; - return $self; + return $self; } -## accessors +## accessors sub options { (shift)->{'%!options'} } sub meta_instance { (shift)->{'$!meta_instance'} } @@ -53,39 +53,39 @@ sub associated_metaclass { (shift)->{'$!associated_metaclass'} } sub intialize_body { 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 %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 {'; $source .= "\n" . 'my $class = shift;'; - + $source .= "\n" . 'return $class->Moose::Object::new(@_)'; - $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';'; - - $source .= "\n" . 'my %params = (scalar @_ == 1) ? %{$_[0]} : @_;'; - + $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';'; + + $source .= "\n" . 'my %params = (scalar @_ == 1) ? %{$_[0]} : @_;'; + $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class'); - - $source .= ";\n" . (join ";\n" => map { - $self->_generate_slot_initializer($_) + + $source .= ";\n" . (join ";\n" => map { + $self->_generate_slot_initializer($_) } 0 .. (@{$self->attributes} - 1)); - + $source .= ";\n" . $self->_generate_BUILDALL(); - + $source .= ";\n" . 'return $instance'; - $source .= ";\n" . '}'; - warn $source if $self->options->{debug}; - + $source .= ";\n" . '}'; + warn $source if $self->options->{debug}; + my $code; { # NOTE: # create the nessecary lexicals - # to be picked up in the eval + # to be picked up in the eval my $attrs = $self->attributes; - + $code = eval $source; confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@; } @@ -96,56 +96,56 @@ sub _generate_BUILDALL { my $self = shift; my @BUILD_calls; foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) { - push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD(\%params)'; + push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD(\%params)'; } - return join ";\n" => @BUILD_calls; + return join ";\n" => @BUILD_calls; } sub _generate_slot_initializer { my $self = shift; my $index = shift; - + my $attr = $self->attributes->[$index]; - + my @source = ('## ' . $attr->name); my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME - - if ($is_moose && $attr->is_required && !$attr->has_default) { - push @source => ('(exists $params{\'' . $attr->init_arg . '\'}) ' . + + if ($is_moose && $attr->is_required && !$attr->has_default && !$attr->has_builder) { + push @source => ('(exists $params{\'' . $attr->init_arg . '\'}) ' . '|| confess "Attribute (' . $attr->name . ') is required";'); } - + if ($attr->has_default && !($is_moose &&$attr->is_lazy)) { - + push @source => 'if (exists $params{\'' . $attr->init_arg . '\'}) {'; push @source => ('my $val = $params{\'' . $attr->init_arg . '\'};'); if ($is_moose && $attr->has_type_constraint) { push @source => ('my $type_constraint = $attrs->[' . $index . ']->type_constraint;'); - if ($attr->should_coerce && $attr->type_constraint->has_coercion) { - push @source => $self->_generate_type_coercion($attr, '$type_constraint', '$val', '$val'); + if ($attr->should_coerce && $attr->type_constraint->has_coercion) { + push @source => $self->_generate_type_coercion($attr, '$type_constraint', '$val', '$val'); } - push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val'); + push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val'); } - push @source => $self->_generate_slot_assignment($attr, '$val'); - - - push @source => "} else {"; - - my $default = $self->_generate_default_value($attr, $index); - + push @source => $self->_generate_slot_assignment($attr, '$val'); + + + push @source => "} else {"; + + my $default = $self->_generate_default_value($attr, $index); + push @source => ('my $val = ' . $default . ';'); push @source => $self->_generate_type_constraint_check( $attr, - ('$attrs->[' . $index . ']->type_constraint'), + ('$attrs->[' . $index . ']->type_constraint'), '$val' - ) if ($is_moose && $attr->has_type_constraint); - push @source => $self->_generate_slot_assignment($attr, $default); - - push @source => "}"; - } + ) if ($is_moose && $attr->has_type_constraint); + push @source => $self->_generate_slot_assignment($attr, $default); + + push @source => "}"; + } else { push @source => '(exists $params{\'' . $attr->init_arg . '\'}) && do {'; @@ -153,16 +153,16 @@ sub _generate_slot_initializer { if ($is_moose && $attr->has_type_constraint) { push @source => ('my $type_constraint = $attrs->[' . $index . ']->type_constraint;'); - if ($attr->should_coerce && $attr->type_constraint->has_coercion) { - push @source => $self->_generate_type_coercion($attr, '$type_constraint', '$val', '$val'); + if ($attr->should_coerce && $attr->type_constraint->has_coercion) { + push @source => $self->_generate_type_coercion($attr, '$type_constraint', '$val', '$val'); } - push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val'); + push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val'); } - push @source => $self->_generate_slot_assignment($attr, '$val'); - - push @source => "}"; + push @source => $self->_generate_slot_assignment($attr, '$val'); + + push @source => "}"; } - + return join "\n" => @source; } @@ -170,25 +170,25 @@ sub _generate_slot_assignment { my ($self, $attr, $value) = @_; my $source = ( $self->meta_instance->inline_set_slot_value( - '$instance', - ("'" . $attr->name . "'"), + '$instance', + ("'" . $attr->name . "'"), $value ) . ';' - ); + ); my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME - + if ($is_moose && $attr->is_weak_ref) { $source .= ( "\n" . $self->meta_instance->inline_weaken_slot_value( - '$instance', + '$instance', ("'" . $attr->name . "'") - ) . + ) . ' if ref ' . $value . ';' - ); - } - + ); + } + return $source; } @@ -201,17 +201,17 @@ sub _generate_type_constraint_check { my ($self, $attr, $type_constraint_name, $value_name) = @_; return ( 'defined(' . $type_constraint_name . '->_compiled_type_constraint->(' . $value_name . '))' - . "\n\t" . '|| confess "Attribute (' . $attr->name . ') does not pass the type constraint (' - . $attr->type_constraint->name + . "\n\t" . '|| confess "Attribute (' . $attr->name . ') does not pass the type constraint (' + . $attr->type_constraint->name . ') with " . (defined(' . $value_name . ') ? (Scalar::Util::blessed(' . $value_name . ') && overload::Overloaded(' . $value_name . ') ? overload::StrVal(' . $value_name . ') : ' . $value_name . ') : "undef");' - ); + ); } sub _generate_default_value { my ($self, $attr, $index) = @_; # NOTE: # default values can either be CODE refs - # in which case we need to call them. Or + # in which case we need to call them. Or # they can be scalars (strings/numbers) # in which case we can just deal with them # in the code we eval. @@ -224,9 +224,9 @@ sub _generate_default_value { unless (looks_like_number($default)) { $default = "'$default'"; } - + return $default; - } + } } 1; @@ -235,15 +235,15 @@ __END__ =pod -=head1 NAME +=head1 NAME Moose::Meta::Method::Constructor - Method Meta Object for constructors =head1 DESCRIPTION -This is a subclass of L which handles -constructing an approprate Constructor methods. This is primarily -used in the making of immutable metaclasses, otherwise it is +This is a subclass of L which handles +constructing an approprate Constructor methods. This is primarily +used in the making of immutable metaclasses, otherwise it is not particularly useful. =head1 METHODS @@ -275,7 +275,7 @@ Copyright 2006, 2007 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut diff --git a/t/300_immutable/001_immutable_moose.t b/t/300_immutable/001_immutable_moose.t index f057976..1a4dd25 100644 --- a/t/300_immutable/001_immutable_moose.t +++ b/t/300_immutable/001_immutable_moose.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 8; +use Test::More tests => 12; use Test::Exception; BEGIN { @@ -20,15 +20,27 @@ BEGIN { { package Foo; use Moose; + + has 'foos' => (is => 'ro', lazy_build => 1); + sub _build_foos{ "many foos" } + } { my $foo_role = Moose::Meta::Role->initialize('FooRole'); my $meta = Foo->meta; + + lives_ok{ Foo->new } "lazy_build works"; + is(Foo->new->foos, 'many foos' , "correct value for 'foos'"); lives_ok{ $meta->make_immutable } "Foo is imutable"; dies_ok{ $meta->add_role($foo_role) } "Add Role is locked"; + lives_ok{ Foo->new } "Inlined constructor works with lazy_build"; + is(Foo->new->foos, 'many foos' , "correct value for 'foos'"); lives_ok{ $meta->make_mutable } "Foo is mutable"; lives_ok{ $meta->add_role($foo_role) } "Add Role is unlocked"; + + + } {