From: Tokuhiro Matsuno Date: Wed, 3 Dec 2008 01:56:41 +0000 (+0000) Subject: - inject object constructor when call meta->make_immutable. X-Git-Tag: 0.19~136^2~79 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=fc1d8369f17d2d6a06ecdcb13199e1d4ecb2e53f - inject object constructor when call meta->make_immutable. - this change makes Obj->new 225% faster --- diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index 5cf70e1..67d012e 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -3,6 +3,7 @@ package Mouse::Meta::Class; use strict; use warnings; +use Mouse::Meta::Method::Constructor; use Mouse::Util qw/get_linear_isa blessed/; use Carp 'confess'; @@ -137,8 +138,17 @@ sub clone_instance { } -sub make_immutable {} -sub is_immutable { 0 } +sub make_immutable { + my $self = shift; + my $name = $self->name; + $self->{is_immutable}++; + no strict 'refs'; + *{"$name\::new"} = Mouse::Meta::Method::Constructor->generate_constructor_method_inline( $self ); +} +sub make_mutable { + Carp::croak "Mouse::Meta::Class->make_mutable does not supported by Mouse"; +} +sub is_immutable { $_[0]->{is_immutable} } sub attribute_metaclass { "Mouse::Meta::Class" } diff --git a/lib/Mouse/Meta/Method/Constructor.pm b/lib/Mouse/Meta/Method/Constructor.pm new file mode 100644 index 0000000..1786d4e --- /dev/null +++ b/lib/Mouse/Meta/Method/Constructor.pm @@ -0,0 +1,138 @@ +package Mouse::Meta::Method::Constructor; +use strict; +use warnings; + +sub generate_constructor_method_inline { + my ($class, $meta) = @_; + my $buildall = $class->_generate_BUILDALL($meta); + my $buildargs = $class->_generate_BUILDARGS(); + my $classname = $meta->name; + my $processattrs = $class->_generate_processattrs($meta); + + my $code = <<"..."; + sub { + my \$class = shift; + my \$args = $buildargs; + my \$instance = bless {}, '$classname'; + $processattrs; + $buildall; + return \$instance; + } +... + warn $code if $ENV{DEBUG}; + + my $res = eval $code; + die $@ if $@; + $res; +} + +sub _generate_processattrs { + my ($class, $meta, ) = @_; + my @attrs = $meta->compute_all_applicable_attributes; + my @res; + for my $attr (@attrs) { + my $from = $attr->init_arg; + my $key = $attr->name; + my $part1 = do { + my @code; + if ($attr->should_coerce) { + push @code, "\$args->{\$from} = \$attr->coerce_constraint( \$args->{\$from} );"; + } + if ($attr->has_type_constraint) { + push @code, "\$attr->verify_type_constraint( \$args->{\$from} );"; + } + push @code, "\$instance->{\$key} = \$args->{\$from};"; + push @code, "weaken( \$instance->{\$key} ) if ref( \$instance->{\$key} ) && \$attr->is_weak_ref;"; + if ( $attr->has_trigger ) { + push @code, "\$attr->trigger->( \$instance, \$args->{\$from}, \$attr );"; + } + join "\n", @code; + }; + my $part2 = do { + my @code; + if ( $attr->has_default || $attr->has_builder ) { + unless ( $attr->is_lazy ) { + my $default = $attr->default; + my $builder = $attr->builder; + if ($attr->has_builder) { + push @code, "my \$value = \$instance->$builder;"; + } elsif (ref($default) eq 'CODE') { + push @code, "my \$value = \$attr->default()->();"; + } else { + push @code, "my \$value = \$attr->default();"; + } + if ($attr->should_coerce) { + push @code, "\$value = \$attr->coerce_constraint(\$value);"; + } + if ($attr->has_type_constraint) { + push @code, "\$attr->verify_type_constraint(\$value);"; + } + push @code, "\$instance->{\$key} = \$value;"; + if ($attr->is_weak_ref) { + push @code, "weaken( \$instance->{\$key} ) if ref( \$instance->{\$key} );"; + } + } + join "\n", @code; + } + else { + if ( $attr->is_required ) { + q{Carp::confess("Attribute (} . $attr->name . q{) is required");}; + } else { + "" + } + } + }; + my $code = <<"..."; + { + my \$attr = \$instance->meta->get_attribute_map->{'$key'}; + my \$from = '$from'; + my \$key = '$key'; + if (defined(\$from) && exists(\$args->{\$from})) { + $part1; + } else { + $part2; + } + } +... + push @res, $code; + } + return join "\n", @res; +} + +sub _generate_BUILDARGS { + <<'...'; + do { + if ( scalar @_ == 1 ) { + if ( defined $_[0] ) { + ( ref( $_[0] ) eq 'HASH' ) + || Carp::confess "Single parameters to new() must be a HASH ref"; + +{ %{ $_[0] } }; + } + else { + +{}; + } + } + else { + +{@_}; + } + }; +... +} + +sub _generate_BUILDALL { + my ($class, $meta) = @_; + return '' unless $meta->name->can('BUILD'); + + my @code = (); + push @code, q{no strict 'refs';}; + push @code, q{no warnings 'once';}; + no strict 'refs'; + for my $class ($meta->linearized_isa) { + if (*{ $class . '::BUILD' }{CODE}) { + push @code, qq{${class}::BUILD->(\$instance, \$args);}; + } + } + return join "\n", @code; +} + +1; diff --git a/lib/Mouse/Object.pm b/lib/Mouse/Object.pm index a49d08c..fcfaf6b 100644 --- a/lib/Mouse/Object.pm +++ b/lib/Mouse/Object.pm @@ -16,7 +16,6 @@ sub new { for my $attribute ($class->meta->compute_all_applicable_attributes) { my $from = $attribute->init_arg; my $key = $attribute->name; - my $default; if (defined($from) && exists($args->{$from})) { $args->{$from} = $attribute->coerce_constraint($args->{$from}) diff --git a/t/300_immutable/001_immutable_moose.t b/t/300_immutable/001_immutable_moose.t new file mode 100644 index 0000000..2e1f74c --- /dev/null +++ b/t/300_immutable/001_immutable_moose.t @@ -0,0 +1,92 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 15; +use Test::Exception; + +use Mouse::Meta::Role; + + +{ + package FooRole; + our $VERSION = '0.01'; + sub foo {'FooRole::foo'} +} + +{ + package Foo; + use Mouse; + + #two checks because the inlined methods are different when + #there is a TC present. + has 'foos' => ( is => 'ro', lazy_build => 1 ); + has 'bars' => ( isa => 'Str', is => 'ro', lazy_build => 1 ); + has 'bazes' => ( isa => 'Str', is => 'ro', builder => '_build_bazes' ); + sub _build_foos {"many foos"} + sub _build_bars {"many bars"} + sub _build_bazes {"many bazes"} +} + +{ + my $foo_role = Mouse::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' before inlining constructor" ); + is( Foo->new->bars, 'many bars', + "correct value for 'bars' before inlining constructor" ); + is( Foo->new->bazes, 'many bazes', + "correct value for 'bazes' before inlining constructor" ); + lives_ok { $meta->make_immutable } "Foo is imutable"; + SKIP: { + skip "Mouse doesn't supports ->identifier, add_role", 2; + lives_ok { $meta->identifier } "->identifier on metaclass lives"; + 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' after inlining constructor" ); + is( Foo->new->bars, 'many bars', + "correct value for 'bars' after inlining constructor" ); + is( Foo->new->bazes, 'many bazes', + "correct value for 'bazes' after inlining constructor" ); + SKIP: { + skip "Mouse doesn't supports make_mutable", 2; + lives_ok { $meta->make_mutable } "Foo is mutable"; + lives_ok { $meta->add_role($foo_role) } "Add Role is unlocked"; + }; + +} + +{ + package Bar; + + use Mouse; + + sub BUILD { 'bar' } +} + +{ + package Baz; + + use Mouse; + + extends 'Bar'; + + sub BUILD { 'baz' } +} + +lives_ok { Bar->meta->make_immutable } + 'Immutable meta with single BUILD'; + +lives_ok { Baz->meta->make_immutable } + 'Immutable meta with multiple BUILDs'; + +=pod + +Nothing here yet, but soon :) + +=cut diff --git a/t/300_immutable/007_immutable_trigger_from_constructor.t b/t/300_immutable/007_immutable_trigger_from_constructor.t new file mode 100644 index 0000000..cab557f --- /dev/null +++ b/t/300_immutable/007_immutable_trigger_from_constructor.t @@ -0,0 +1,40 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 3; +use Test::Exception; + + + +{ + package AClass; + + use Moose; + + has 'foo' => (is => 'rw', isa => 'Maybe[Str]', trigger => sub { + die "Pulling the Foo trigger\n" + }); + + has 'bar' => (is => 'rw', isa => 'Maybe[Str]'); + + has 'baz' => (is => 'rw', isa => 'Maybe[Str]', trigger => sub { + die "Pulling the Baz trigger\n" + }); + + __PACKAGE__->meta->make_immutable; #(debug => 1); + + no Moose; +} + +eval { AClass->new(foo => 'bar') }; +like ($@, qr/^Pulling the Foo trigger/, "trigger from immutable constructor"); + +eval { AClass->new(baz => 'bar') }; +like ($@, qr/^Pulling the Baz trigger/, "trigger from immutable constructor"); + +lives_ok { AClass->new(bar => 'bar') } '... no triggers called'; + + + diff --git a/t/300_immutable/008_immutable_constructor_error.t b/t/300_immutable/008_immutable_constructor_error.t new file mode 100644 index 0000000..62d6d3c --- /dev/null +++ b/t/300_immutable/008_immutable_constructor_error.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; +use Test::Exception; + + + +=pod + +This tests to make sure that we provide the same error messages from +an immutable constructor as is provided by a non-immutable +constructor. + +=cut + +{ + package Foo; + use Moose; + + has 'foo' => (is => 'rw', isa => 'Int'); + + Foo->meta->make_immutable(debug => 0); +} + +my $scalar = 1; +throws_ok { Foo->new($scalar) } qr/\QSingle parameters to new() must be a HASH ref/, + 'Non-ref provided to immutable constructor gives useful error message'; +throws_ok { Foo->new(\$scalar) } qr/\QSingle parameters to new() must be a HASH ref/, + 'Scalar ref provided to immutable constructor gives useful error message'; + diff --git a/t/300_immutable/009_buildargs.t b/t/300_immutable/009_buildargs.t new file mode 100644 index 0000000..6c1ca33 --- /dev/null +++ b/t/300_immutable/009_buildargs.t @@ -0,0 +1,47 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 14; + +{ + package Foo; + use Moose; + + has bar => ( is => "rw" ); + has baz => ( is => "rw" ); + + sub BUILDARGS { + my ( $self, @args ) = @_; + unshift @args, "bar" if @args % 2 == 1; + return {@args}; + } + + __PACKAGE__->meta->make_immutable; + + package Bar; + use Moose; + + extends qw(Foo); + + __PACKAGE__->meta->make_immutable; +} + +foreach my $class qw(Foo Bar) { + is( $class->new->bar, undef, "no args" ); + is( $class->new( bar => 42 )->bar, 42, "normal args" ); + is( $class->new( 37 )->bar, 37, "single arg" ); + { + my $o = $class->new(bar => 42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } + { + my $o = $class->new(42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } +} + + diff --git a/t/803-make_immutable.t b/t/803-make_immutable.t new file mode 100644 index 0000000..111fb3d --- /dev/null +++ b/t/803-make_immutable.t @@ -0,0 +1,32 @@ +use strict; +use warnings; +use Test::More tests => 4; +use t::Exception; + +{ + package HardDog; + use Mouse; + has bone => ( + is => 'rw', + required => 1, + ); + no Mouse; + __PACKAGE__->meta->make_immutable; +} + +{ + package SoftDog; + use Mouse; + has bone => ( + is => 'rw', + required => 1, + ); + no Mouse; +} + +lives_ok { SoftDog->new(bone => 'moo') }; +lives_ok { HardDog->new(bone => 'moo') }; + +throws_ok { SoftDog->new() } qr/\QAttribute (bone) is required/; +throws_ok { HardDog->new() } qr/\QAttribute (bone) is required/; +