X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FMeta%2FMethod%2FConstructor.pm;h=610e98ac6191279b352e5147fdc0b10c2ffcd1d9;hb=f1575d9f6d73252e751770a6c7ac717237059f29;hp=e57dd6e9117162b6d7d24c48d37f7479fba6ae74;hpb=6e1e5b31f9ff0a46de1d7e396840da18c385962d;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Meta/Method/Constructor.pm b/lib/Mouse/Meta/Method/Constructor.pm index e57dd6e..610e98a 100644 --- a/lib/Mouse/Meta/Method/Constructor.pm +++ b/lib/Mouse/Meta/Method/Constructor.pm @@ -1,97 +1,69 @@ package Mouse::Meta::Method::Constructor; use Mouse::Util qw(:meta); # enables strict and warnings -sub _inline_create_instance { - my(undef, $class_expr) = @_; - return "bless {}, $class_expr"; -} +use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0; -sub _inline_slot { +sub _inline_slot{ my(undef, $self_var, $attr_name) = @_; return sprintf '%s->{q{%s}}', $self_var, $attr_name; } -sub _inline_has_slot { - my($class, $self_var, $attr_name) = @_; - - return sprintf 'exists(%s)', $class->_inline_slot($self_var, $attr_name); -} - -sub _inline_get_slot { - my($class, $self_var, $attr_name) = @_; - - return $class->_inline_slot($self_var, $attr_name); -} - -sub _inline_set_slot { - my($class, $self_var, $attr_name, $rvalue) = @_; - - return $class->_inline_slot($self_var, $attr_name) . " = $rvalue"; -} - -sub _inline_weaken_slot { - my($class, $self_var, $attr_name) = @_; - - return sprintf 'Scalar::Util::weaken(%s)', $class->_inline_slot($self_var, $attr_name); -} - sub _generate_constructor { my ($class, $metaclass, $args) = @_; - my @attrs = $metaclass->get_all_attributes; + my $associated_metaclass_name = $metaclass->name; - my $init_attrs = $class->_generate_processattrs($metaclass, \@attrs); - my $buildargs = $class->_generate_BUILDARGS($metaclass); my $buildall = $class->_generate_BUILDALL($metaclass); - - my @checks = map { $_ && $_->_compiled_type_constraint } - map { $_->type_constraint } @attrs; - - my $class_name = $metaclass->name; - my $source = sprintf(<<'END_CONSTRUCTOR', $class_name, __LINE__, __FILE__, $class_name, $buildargs, $class->_inline_create_instance('$class'), $init_attrs, $buildall); -package %s; -#line %d "constructor of %s (%s)" + my $buildargs = $class->_generate_BUILDARGS($metaclass); + my $initializer = $metaclass->{_mouse_cache}{_initialize_object} ||= + $class->_generate_initialize_object($metaclass); + my $source = sprintf(<<'EOT', __FILE__, $metaclass->name, $buildargs, $buildall); +#line 1 "%s" + package %s; sub { my $class = shift; return $class->Mouse::Object::new(@_) if $class ne __PACKAGE__; # BUILDARGS %s; - # create instance - my $instance = %s; - # process attributes - %s; + my $instance = bless {}, $class; + $metaclass->$initializer($instance, $args, 0); # BUILDALL %s; return $instance; } -END_CONSTRUCTOR - #warn $source; - my $code; +EOT + warn $source if _MOUSE_DEBUG; + my $body; my $e = do{ local $@; - $code = eval $source; + $body = eval $source; $@; }; die $e if $e; - return $code; + return $body; } -sub _generate_processattrs { - my ($method_class, $metaclass, $attrs) = @_; +sub _generate_initialize_object { + my ($method_class, $metaclass) = @_; + my @attrs = $metaclass->get_all_attributes; + + my @checks = map { $_ && $_->_compiled_type_constraint } + map { $_->type_constraint } @attrs; + my @res; my $has_triggers; - my $strict = $metaclass->__strict_constructor; + my $strict = $metaclass->strict_constructor; if($strict){ push @res, 'my $used = 0;'; } - for my $index (0 .. @$attrs - 1) { + for my $index (0 .. @attrs - 1) { my $code = ''; - my $attr = $attrs->[$index]; + my $attr = $attrs[$index]; my $key = $attr->name; my $init_arg = $attr->init_arg; @@ -99,8 +71,7 @@ sub _generate_processattrs { my $is_weak_ref = $attr->is_weak_ref; my $need_coercion; - my $instance = '$instance'; - my $instance_slot = $method_class->_inline_get_slot($instance, $key); + my $instance_slot = $method_class->_inline_slot('$instance', $key); my $attr_var = "\$attrs[$index]"; my $constraint_var; @@ -113,13 +84,11 @@ sub _generate_processattrs { my $post_process = ''; if(defined $type_constraint){ - $post_process .= "\$checks[$index]->($instance_slot)"; + $post_process .= "\$checks[$index]->($instance_slot)\n"; $post_process .= " or $attr_var->_throw_type_constraint_error($instance_slot, $constraint_var);\n"; } - if($is_weak_ref){ - $post_process .= $method_class->_inline_weaken_slot($instance, $key) . " if ref $instance_slot;\n"; - } + # build cde for an attribute if (defined $init_arg) { my $value = "\$args->{q{$init_arg}}"; @@ -129,7 +98,7 @@ sub _generate_processattrs { $value = "$constraint_var->coerce($value)"; } - $code .= $method_class->_inline_set_slot($instance, $key, $value) . ";\n"; + $code .= "$instance_slot = $value;\n"; $code .= $post_process; if ($attr->has_trigger) { @@ -167,28 +136,32 @@ sub _generate_processattrs { $value = "$constraint_var->coerce($value)"; } - $code .= $method_class->_inline_set_slot($instance, $key, $value) . ";\n"; - if($is_weak_ref){ - $code .= $method_class->_inline_weaken_slot($instance, $key) . ";\n"; - } + $code .= "$instance_slot = $value;\n"; + $code .= $post_process; } } elsif ($attr->is_required) { - $code .= "Carp::confess('Attribute ($key) is required');"; + $code .= "\$meta->throw_error('Attribute ($key) is required')"; + $code .= " unless \$is_cloning;\n"; } $code .= "}\n" if defined $init_arg; + if($is_weak_ref){ + $code .= "Scalar::Util::weaken($instance_slot) " + . "if ref $instance_slot;\n"; + } + push @res, $code; } if($strict){ push @res, q{if($used < keys %{$args})} - . sprintf q{{ %s->_report_unknown_args($metaclass, \@attrs, $args) }}, $method_class; + . q{{ $meta->_report_unknown_args(\@attrs, $args) }}; } if($metaclass->is_anon_class){ - push @res, q{$instance->{__METACLASS__} = $metaclass;}; + push @res, q{$instance->{__METACLASS__} = $meta;}; } if($has_triggers){ @@ -196,7 +169,24 @@ sub _generate_processattrs { push @res, q{$_->[0]->($instance, $_->[1]) for @triggers;}; } - return join "\n", @res; + my $source = sprintf <<'EOT', __FILE__, $metaclass->name, join "\n", @res; +#line 1 "%s" + package %s; + sub { + my($meta, $instance, $args, $is_cloning) = @_; + %s; + return $instance; + } +EOT + warn $source if _MOUSE_DEBUG; + my $body; + my $e = do { + local $@; + $body = eval $source; + $@; + }; + die $e if $e; + return $body; } sub _generate_BUILDARGS { @@ -234,30 +224,6 @@ sub _generate_BUILDALL { return join "\n", @code; } -sub _report_unknown_args { - my(undef, $metaclass, $attrs, $args) = @_; - - my @unknowns; - my %init_args; - foreach my $attr(@{$attrs}){ - my $init_arg = $attr->init_arg; - if(defined $init_arg){ - $init_args{$init_arg}++; - } - } - - while(my $key = each %{$args}){ - if(!exists $init_args{$key}){ - push @unknowns, $key; - } - } - - $metaclass->throw_error( sprintf - "Unknown attribute passed to the constructor of %s: %s", - $metaclass->name, Mouse::Util::english_list(@unknowns), - ); -} - 1; __END__ @@ -267,7 +233,7 @@ Mouse::Meta::Method::Constructor - A Mouse method generator for constructors =head1 VERSION -This document describes Mouse version 0.50_06 +This document describes Mouse version 0.92 =head1 SEE ALSO