X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FMeta%2FMethod%2FConstructor.pm;h=4312f5efbfe88e525aee527c29bbc20f1509c353;hp=1211e612d126fa1ef6636e26402d52b16caa3bf9;hb=b06ce1f502945c13a52c503f1a651fe92c91c773;hpb=ad087d1140e1f90a85f2f47cc05bd648fb4ea38e diff --git a/lib/Mouse/Meta/Method/Constructor.pm b/lib/Mouse/Meta/Method/Constructor.pm index 1211e61..4312f5e 100644 --- a/lib/Mouse/Meta/Method/Constructor.pm +++ b/lib/Mouse/Meta/Method/Constructor.pm @@ -1,35 +1,41 @@ package Mouse::Meta::Method::Constructor; -use strict; -use warnings; +use Mouse::Util qw(get_code_ref); # enables strict and warnings -sub _generate_constructor_method { +sub _inline_slot{ + my(undef, $self_var, $attr_name) = @_; + return sprintf '%s->{q{%s}}', $self_var, $attr_name; +} + +sub _generate_constructor { my ($class, $metaclass, $args) = @_; my $associated_metaclass_name = $metaclass->name; + my @attrs = $metaclass->get_all_attributes; my $buildall = $class->_generate_BUILDALL($metaclass); my $buildargs = $class->_generate_BUILDARGS($metaclass); my $processattrs = $class->_generate_processattrs($metaclass, \@attrs); - my @compiled_constraints = map { $_ ? $_->_compiled_type_constraint : undef } - map { $_->type_constraint } @attrs; - - + my @checks = map { $_ && $_->_compiled_type_constraint } + map { $_->type_constraint } @attrs; my $source = sprintf("#line %d %s\n", __LINE__, __FILE__).<<"..."; sub \{ my \$class = shift; return \$class->Mouse::Object::new(\@_) if \$class ne q{$associated_metaclass_name}; + # BUILDARGS $buildargs; my \$instance = bless {}, \$class; + # process attributes $processattrs; + # BUILDALL $buildall; return \$instance; } ... - + #warn $source; my $code; my $e = do{ local $@; @@ -37,47 +43,60 @@ sub _generate_constructor_method { $@; }; die $e if $e; - - $metaclass->add_method($args->{constructor_name} => $code); - return; + return $code; } sub _generate_processattrs { - my ($class, $metaclass, $attrs) = @_; + my ($method_class, $metaclass, $attrs) = @_; my @res; my $has_triggers; for my $index (0 .. @$attrs - 1) { + my $code = ''; + my $attr = $attrs->[$index]; my $key = $attr->name; - my $code = ''; - if (defined $attr->init_arg) { - my $from = $attr->init_arg; + my $init_arg = $attr->init_arg; + my $type_constraint = $attr->type_constraint; + my $need_coercion; - $code .= "if (exists \$args->{q{$from}}) {\n"; + my $instance_slot = $method_class->_inline_slot('$instance', $key); + my $attr_var = "\$attrs[$index]"; + my $constraint_var; - my $value = "\$args->{q{$from}}"; - if(my $type_constraint = $attr->type_constraint){ - if($attr->should_coerce && $type_constraint->has_coercion){ - $code .= "my \$value = \$attrs[$index]->{type_constraint}->coerce(\$args->{q{$from}});\n"; - $value = '$value'; - } + if(defined $type_constraint){ + $constraint_var = "$attr_var\->{type_constraint}"; + $need_coercion = ($attr->should_coerce && $type_constraint->has_coercion); + } - $code .= "\$compiled_constraints[$index]->($value)\n"; - $code .= " or \$attrs[$index]->verify_type_constraint_error(q{$key}, $value, \$attrs[$index]->{type_constraint});\n"; - } + $code .= "# initialize $key\n"; - $code .= "\$instance->{q{$key}} = $value;\n"; + my $post_process = ''; + if(defined $type_constraint){ + $post_process .= "\$checks[$index]->($instance_slot)"; + $post_process .= " or $attr_var->verify_type_constraint_error(q{$key}, $instance_slot, $constraint_var);\n"; + } + if($attr->is_weak_ref){ + $post_process .= "Scalar::Util::weaken($instance_slot) if ref $instance_slot;\n"; + } + + if (defined $init_arg) { + my $value = "\$args->{q{$init_arg}}"; - if ($attr->is_weak_ref) { - $code .= "Scalar::Util::weaken( \$instance->{q{$key}} ) if ref($value);\n"; + $code .= "if (exists $value) {\n"; + + if($need_coercion){ + $value = "$constraint_var->coerce($value)"; } + $code .= "$instance_slot = $value;\n"; + $code .= $post_process; + if ($attr->has_trigger) { $has_triggers++; - $code .= "push \@triggers, [\$attrs[$index]->{trigger}, $value];\n"; + $code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n"; } $code .= "\n} else {\n"; @@ -88,61 +107,38 @@ sub _generate_processattrs { my $default = $attr->default; my $builder = $attr->builder; - $code .= "my \$value = "; - - if ($attr->should_coerce && $attr->type_constraint) { - $code .= "\$attrs[$index]->_coerce_and_verify("; - } - - if ($attr->has_builder) { - $code .= "\$instance->$builder()"; + my $value; + if (defined($builder)) { + $value = "\$instance->$builder()"; } elsif (ref($default) eq 'CODE') { - $code .= "\$attrs[$index]->{default}->(\$instance)"; + $value = "$attr_var\->{default}->(\$instance)"; } - elsif (!defined($default)) { - $code .= 'undef'; - } - elsif ($default =~ /^\-?[0-9]+(?:\.[0-9]+)$/) { - $code .= $default; + elsif (defined($default)) { + $value = "$attr_var\->{default}"; } else { - $code .= "'$default'"; + $value = 'undef'; } - if ($attr->should_coerce) { - $code .= ");\n"; + if($need_coercion){ + $value = "$constraint_var->coerce($value)"; } - else { - $code .= ";\n"; - } - - if ($attr->has_type_constraint) { - $code .= "{ - unless (\$attrs[$index]->{type_constraint}->check(\$value)) { - \$attrs[$index]->verify_type_constraint_error(q{$key}, \$value, \$attrs[$index]->type_constraint) - } - }"; - } - - $code .= "\$instance->{q{$key}} = \$value;\n"; - if ($attr->is_weak_ref) { - $code .= "Scalar::Util::weaken( \$instance->{q{$key}} ) if ref( \$value );\n"; - } + $code .= "$instance_slot = $value;\n"; } } elsif ($attr->is_required) { $code .= "Carp::confess('Attribute ($key) is required');"; } - $code .= "}\n" if defined $attr->init_arg; + $code .= "}\n" if defined $init_arg; push @res, $code; } if($metaclass->is_anon_class){ - push @res, q{$instnace->{__METACLASS__} = $metaclass;}; + push @res, q{$instance->{__METACLASS__} = $metaclass;}; } if($has_triggers){ @@ -154,9 +150,10 @@ sub _generate_processattrs { } sub _generate_BUILDARGS { - my($self, $metaclass) = @_; + my(undef, $metaclass) = @_; - if ($metaclass->name->can('BUILDARGS') && $metaclass->name->can('BUILDARGS') != \&Mouse::Object::BUILDARGS) { + my $class = $metaclass->name; + if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) { return 'my $args = $class->BUILDARGS(@_)'; } @@ -174,16 +171,13 @@ sub _generate_BUILDARGS { } sub _generate_BUILDALL { - my ($class, $metaclass) = @_; + my (undef, $metaclass) = @_; return '' unless $metaclass->name->can('BUILD'); my @code; for my $class ($metaclass->linearized_isa) { - no strict 'refs'; - no warnings 'once'; - - if (*{ $class . '::BUILD' }{CODE}) { + if (get_code_ref($class, 'BUILD')) { unshift @code, qq{${class}::BUILD(\$instance, \$args);}; } } @@ -191,3 +185,18 @@ sub _generate_BUILDALL { } 1; +__END__ + +=head1 NAME + +Mouse::Meta::Method::Constructor - A Mouse method generator for constructors + +=head1 VERSION + +This document describes Mouse version 0.40_01 + +=head1 SEE ALSO + +L + +=cut