From: Stevan Little Date: Fri, 10 Nov 2006 04:10:56 +0000 (+0000) Subject: Moose Immutable X-Git-Tag: 0_18_002~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5cf3dbcf66d39c700f7b66a20c9bc7e2bbc025ab;p=gitmo%2FMoose.git Moose Immutable --- diff --git a/benchmarks/immutable.pl b/benchmarks/immutable.pl new file mode 100644 index 0000000..c9ad538 --- /dev/null +++ b/benchmarks/immutable.pl @@ -0,0 +1,78 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Scalar::Util 'blessed'; +use Benchmark qw[cmpthese]; + +use Moose::Util::TypeConstraints; + +BEGIN { + subtype 'Foo' => as 'Object' => where { blessed($_) && $_->isa('Foo') }; + + coerce 'Foo' + => from 'ArrayRef' + => via { Foo->new(@{$_}) }; +} + +{ + package Foo; + use Moose; +} + +{ + package Foo::Normal; + use Moose; + + has 'default' => (is => 'rw', default => 10); + has 'default_sub' => (is => 'rw', default => sub { [] }); + has 'lazy' => (is => 'rw', default => 10, lazy => 1); + has 'required' => (is => 'rw', required => 1); + has 'weak_ref' => (is => 'rw', weak_ref => 1); + has 'type_constraint' => (is => 'rw', isa => 'Foo'); + has 'coercion' => (is => 'rw', isa => 'Foo', coerce => 1); + +} + +{ + package Foo::Immutable; + use Moose; + + has 'default' => (is => 'rw', default => 10); + has 'default_sub' => (is => 'rw', default => sub { [] }); + has 'lazy' => (is => 'rw', default => 10, lazy => 1); + has 'required' => (is => 'rw', required => 1); + has 'weak_ref' => (is => 'rw', weak_ref => 1); + has 'type_constraint' => (is => 'rw', isa => 'Foo'); + has 'coercion' => (is => 'rw', isa => 'Foo', coerce => 1); + + sub BUILD { + # ... + } + + Foo::Immutable->meta->make_immutable(debug => 1); +} + +#__END__ + +my $foo = Foo->new; + +cmpthese(500, + { + 'normal' => sub { + Foo::Normal->new( + required => 'BAR', + type_constraint => $foo, + #coercion => [], + ); + }, + 'immutable' => sub { + Foo::Immutable->new( + required => 'BAR', + type_constraint => $foo, + #coercion => [], + ); + }, + } +); \ No newline at end of file diff --git a/lib/Moose.pm b/lib/Moose.pm index 3264473..fa6b012 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -1,4 +1,6 @@ +use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/branches/Class-MOP-tranformations/lib'; + package Moose; use strict; @@ -214,6 +216,8 @@ use Moose::Util::TypeConstraints; } } } + + } ## Utility functions diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 7e5d102..1b4d052 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -24,9 +24,9 @@ sub initialize { my $class = shift; my $pkg = shift; $class->SUPER::initialize($pkg, - ':attribute_metaclass' => 'Moose::Meta::Attribute', - ':method_metaclass' => 'Moose::Meta::Method', - ':instance_metaclass' => 'Moose::Meta::Instance', + 'attribute_metaclass' => 'Moose::Meta::Attribute', + 'method_metaclass' => 'Moose::Meta::Method', + 'instance_metaclass' => 'Moose::Meta::Instance', @_); } @@ -102,7 +102,7 @@ sub construct_instance { # This is ugly sub get_method_map { my $self = shift; - my $map = $self->{'%:methods'}; + my $map = $self->{'%!methods'}; my $class_name = $self->name; my $method_metaclass = $self->method_metaclass; @@ -133,25 +133,6 @@ sub get_method_map { return $map; } -#sub find_method_by_name { -# my ($self, $method_name) = @_; -# (defined $method_name && $method_name) -# || confess "You must define a method name to find"; -# # keep a record of what we have seen -# # here, this will handle all the -# # inheritence issues because we are -# # using the &class_precedence_list -# my %seen_class; -# foreach my $class ($self->class_precedence_list()) { -# next if $seen_class{$class}; -# $seen_class{$class}++; -# # fetch the meta-class ... -# my $meta = $self->initialize($class); -# return $meta->get_method($method_name) -# if $meta->has_method($method_name); -# } -#} - ### --------------------------------------------- sub add_attribute { @@ -252,9 +233,9 @@ sub _fix_metaclass_incompatability { # at this point anyway, so it's very # much an obscure edge case anyway $self = $super_meta->reinitialize($self->name => ( - ':attribute_metaclass' => $super_meta->attribute_metaclass, - ':method_metaclass' => $super_meta->method_metaclass, - ':instance_metaclass' => $super_meta->instance_metaclass, + 'attribute_metaclass' => $super_meta->attribute_metaclass, + 'method_metaclass' => $super_meta->method_metaclass, + 'instance_metaclass' => $super_meta->instance_metaclass, )); } } @@ -316,6 +297,52 @@ sub _process_inherited_attribute { return $new_attr; } +## ------------------------------------------------- + +use Moose::Meta::Method::Constructor; + +{ + # NOTE: + # the immutable version of a + # particular metaclass is + # really class-level data so + # we don't want to regenerate + # it any more than we need to + my $IMMUTABLE_METACLASS; + sub make_immutable { + my $self = shift; + + $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, { + read_only => [qw/superclasses/], + cannot_call => [qw/ + add_method + alias_method + remove_method + add_attribute + remove_attribute + add_package_symbol + remove_package_symbol + add_role + /], + memoize => { + class_precedence_list => 'ARRAY', + compute_all_applicable_attributes => 'ARRAY', + get_meta_instance => 'SCALAR', + get_method_map => 'SCALAR', + # maybe .... + calculate_all_roles => 'ARRAY', + } + }); + + $IMMUTABLE_METACLASS->make_metaclass_immutable( + $self, + constructor_class => 'Moose::Meta::Method::Constructor', + inline_accessors => 0, + @_, + ) + } +} + 1; __END__ @@ -342,6 +369,8 @@ to the L documentation. =item B +=item B + =item B We override this method to support the C attribute option. diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm new file mode 100644 index 0000000..d80a933 --- /dev/null +++ b/lib/Moose/Meta/Method/Constructor.pm @@ -0,0 +1,268 @@ + +package Moose::Meta::Method::Constructor; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken', 'looks_like_number'; + +our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:STEVAN'; + +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"; + + (blessed $options{meta_instance} && $options{meta_instance}->isa('Class::MOP::Instance')) + || confess "You must supply a meta-instance"; + + (exists $options{attributes} && ref $options{attributes} eq 'ARRAY') + || confess "You must pass an array of options"; + + (blessed($_) && $_->isa('Class::MOP::Attribute')) + || confess "You must supply a list of attributes which is a 'Class::MOP::Attribute' instance" + for @{$options{attributes}}; + + my $self = bless { + # from our superclass + '&!body' => undef, + # specific to this subclass + '%!options' => $options{options}, + '$!meta_instance' => $options{meta_instance}, + '@!attributes' => $options{attributes}, + # ... + '$!associated_metaclass' => $options{metaclass}, + } => $class; + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{'$!meta_instance'}); + weaken($self->{'$!associated_metaclass'}); + + $self->intialize_body; + + return $self; +} + +## accessors + +sub options { (shift)->{'%!options'} } +sub meta_instance { (shift)->{'$!meta_instance'} } +sub attributes { (shift)->{'@!attributes'} } + +sub associated_metaclass { (shift)->{'$!associated_metaclass'} } + +## method + +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 author, after all, nothing is free) + my $source = 'sub {'; + $source .= "\n" . 'my $class = shift; '; + $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($_) + } 0 .. (@{$self->attributes} - 1)); + + $source .= ";\n" . $self->_generate_BUILDALL(); + + $source .= ";\n" . 'return $instance'; + $source .= ";\n" . '}'; + warn $source if $self->options->{debug}; + + my $code; + { + # NOTE: + # create the nessecary lexicals + # 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 $@; + } + $self->{'&!body'} = $code; +} + +sub _generate_BUILDALL { + my $self = shift; + my @BUILD_calls; + foreach my $method ($self->associated_metaclass->find_all_methods_by_name('BUILD')) { + push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD(\%params);'; + } + return join "\n" => @BUILD_calls; +} + +sub _generate_slot_initializer { + my $self = shift; + my $index = shift; + + my $attr = $self->attributes->[$index]; + + my @source = ('## ' . $attr->name); + + if ($attr->is_required && !$attr->has_default) { + push @source => ('(exists $params{\'' . $attr->init_arg . '\'}) ' . + '|| confess "Attribute (' . $attr->name . ') is required";'); + } + + push @source => 'if ($params{\'' . $attr->init_arg . '\'}) {'; + + push @source => ('my $val = $params{\'' . $attr->init_arg . '\'};'); + if ($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'); + } + push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val'); + } + push @source => $self->_generate_slot_assignment($attr, '$val'); + + if ($attr->has_default && !$attr->is_lazy) { + + 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'), + '$val' + ) if $attr->has_type_constraint; + push @source => $self->_generate_slot_assignment($attr, $default); + + push @source => "}"; + } + else { + push @source => "}"; + } + + return join "\n" => @source; +} + +sub _generate_slot_assignment { + my ($self, $attr, $value) = @_; + my $source = ( + $self->meta_instance->inline_set_slot_value( + '$instance', + ("'" . $attr->name . "'"), + $value + ) . ';' + ); + + if ($attr->is_weak_ref) { + $source .= ( + "\n" . + $self->meta_instance->inline_weaken_slot_value( + '$instance', + ("'" . $attr->name . "'") + ) . + ' if ref ' . $value . ';' + ); + } + + return $source; +} + +sub _generate_type_coercion { + my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_; + return ($return_value_name . ' = ' . $type_constraint_name . '->coerce(' . $value_name . ');'); +} + +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 . ') with " . (defined() ? "' . $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 + # they can be scalars (strings/numbers) + # in which case we can just deal with them + # in the code we eval. + if ($attr->is_default_a_coderef) { + return '$attrs->[' . $index . ']->default($instance)'; + } + else { + my $default = $attr->default; + # make sure to quote strings ... + unless (looks_like_number($default)) { + $default = "'$default'"; + } + + return $default; + } +} + +1; + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::Meta::Method::Constructor - Method Meta Object for constructors + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + +=head1 AUTHORS + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 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. + +=cut + diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm index d7bc664..30462e8 100644 --- a/lib/Moose/Meta/Role.pm +++ b/lib/Moose/Meta/Role.pm @@ -153,7 +153,7 @@ sub _clean_up_required_methods { # this is an UGLY hack sub get_method_map { my $self = shift; - $self->{'%:methods'} ||= {}; + $self->{'%!methods'} ||= {}; $self->Moose::Meta::Class::get_method_map() } diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index 3ca4710..8a9d45b 100644 --- a/lib/Moose/Role.pm +++ b/lib/Moose/Role.pm @@ -1,4 +1,6 @@ +use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/branches/Class-MOP-tranformations/lib'; + package Moose::Role; use strict; diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 3df5fba..8a18348 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -1,4 +1,6 @@ +use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/branches/Class-MOP-tranformations/lib'; + package Moose::Util::TypeConstraints; use strict; diff --git a/t/001_recipe.t b/t/001_recipe.t index 7cc3550..771a795 100644 --- a/t/001_recipe.t +++ b/t/001_recipe.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 56; +use Test::More tests => 58; use Test::Exception; BEGIN { @@ -23,6 +23,8 @@ BEGIN { $self->y(0); } + __PACKAGE__->meta->make_immutable(debug => 0); +}{ package Point3D; use Moose; @@ -35,6 +37,7 @@ BEGIN { $self->{z} = 0; }; + __PACKAGE__->meta->make_immutable(debug => 0); } my $point = Point->new(x => 1, y => 2); @@ -125,7 +128,7 @@ is_deeply( [ 'Moose::Object' ], '... Point got the automagic base class'); -my @Point_methods = qw(meta x y clear); +my @Point_methods = qw(meta new x y clear); my @Point_attrs = ('x', 'y'); is_deeply( @@ -157,7 +160,7 @@ is_deeply( [ 'Point' ], '... Point3D gets the parent given to it'); -my @Point3D_methods = qw(meta clear); +my @Point3D_methods = qw(new meta clear); my @Point3D_attrs = ('z'); is_deeply( diff --git a/t/002_recipe.t b/t/002_recipe.t index 447db78..4e0b571 100644 --- a/t/002_recipe.t +++ b/t/002_recipe.t @@ -28,7 +28,9 @@ BEGIN { || confess "Account overdrawn"; $self->balance($current_balance - $amount); } - + + __PACKAGE__->meta->make_immutable(debug => 0); +}{ package CheckingAccount; use Moose; @@ -44,6 +46,8 @@ BEGIN { $self->deposit($overdraft_amount); } }; + + __PACKAGE__->meta->make_immutable(debug => 0); } my $savings_account = BankAccount->new(balance => 250); diff --git a/t/003_recipe.t b/t/003_recipe.t index efe5327..cc7afbd 100644 --- a/t/003_recipe.t +++ b/t/003_recipe.t @@ -45,6 +45,8 @@ BEGIN { my ($self, $tree) = @_; $tree->parent($self) if defined $tree; }; + + __PACKAGE__->meta->make_immutable(debug => 0); } my $root = BinaryTree->new(node => 'root'); diff --git a/t/004_recipe.t b/t/004_recipe.t index b80eaab..d68d211 100644 --- a/t/004_recipe.t +++ b/t/004_recipe.t @@ -45,6 +45,9 @@ BEGIN { has 'state' => (is => 'rw', isa => 'USState'); has 'zip_code' => (is => 'rw', isa => 'USZipCode'); + __PACKAGE__->meta->make_immutable(debug => 0); +}{ + package Company; use Moose; use Moose::Util::TypeConstraints; @@ -79,6 +82,9 @@ BEGIN { } }; + __PACKAGE__->meta->make_immutable(debug => 0); +}{ + package Person; use Moose; @@ -93,6 +99,9 @@ BEGIN { ($self->has_middle_initial ? ' ' . $self->middle_initial . '. ' : ' ') . $self->last_name; } + + __PACKAGE__->meta->make_immutable(debug => 0); +}{ package Employee; use Moose; @@ -106,6 +115,8 @@ BEGIN { my $self = shift; super() . ', ' . $self->title }; + + __PACKAGE__->meta->make_immutable(debug => 0); } my $ii; diff --git a/t/005_recipe.t b/t/005_recipe.t index ac525d7..7ea0371 100644 --- a/t/005_recipe.t +++ b/t/005_recipe.t @@ -61,6 +61,8 @@ BEGIN { coerce => 1, default => sub { HTTP::Headers->new } ); + + __PACKAGE__->meta->make_immutable(debug => 0); } my $r = Request->new; diff --git a/t/006_recipe.t b/t/006_recipe.t index 5251f29..5b8f9d2 100644 --- a/t/006_recipe.t +++ b/t/006_recipe.t @@ -80,6 +80,8 @@ BEGIN { my $self = shift; sprintf '$%0.2f USD' => $self->amount } + + __PACKAGE__->meta->make_immutable(debug => 0); } ok(US::Currency->does('Comparable'), '... US::Currency does Comparable'); diff --git a/t/102_Moose_Object_error.t b/t/102_Moose_Object_error.t index 37e20f3..46868c5 100644 --- a/t/102_Moose_Object_error.t +++ b/t/102_Moose_Object_error.t @@ -3,6 +3,8 @@ use strict; use warnings; +use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/branches/Class-MOP-tranformations/lib'; + use lib 't/lib', 'lib'; use Test::More tests => 1; diff --git a/t/202_example_Moose_POOP.t b/t/202_example_Moose_POOP.t index 6e87c47..1f3589f 100644 --- a/t/202_example_Moose_POOP.t +++ b/t/202_example_Moose_POOP.t @@ -58,7 +58,7 @@ BEGIN { sub create_instance { my $self = shift; - my $class = $self->{meta}->name; + my $class = $self->associated_metaclass->name; my $oid = ++$INSTANCE_COUNTERS{$class}; $db->{$class}->[($oid - 1)] = {}; @@ -71,7 +71,7 @@ BEGIN { sub find_instance { my ($self, $oid) = @_; - my $instance = $db->{$self->{meta}->name}->[($oid - 1)]; + my $instance = $db->{$self->associated_metaclass->name}->[($oid - 1)]; $self->bless_instance_structure({ oid => $oid, instance => $instance @@ -138,7 +138,7 @@ BEGIN { { package Moose::POOP::Object; use metaclass 'Moose::POOP::Meta::Class' => ( - ':instance_metaclass' => 'Moose::POOP::Meta::Instance' + instance_metaclass => 'Moose::POOP::Meta::Instance' ); use Moose;