From: Guillermo Roditi Date: Sat, 2 Jun 2007 17:32:54 +0000 (+0000) Subject: massive updates to the way immutable works to fix a big ish bug, please see new comme... X-Git-Tag: 0_39~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=04dd7510b9fc63582c7da4e249235f108f889975;p=gitmo%2FClass-MOP.git massive updates to the way immutable works to fix a big ish bug, please see new comments in Class::MOP::Class for my logic --- diff --git a/Changes b/Changes index 917c69d..59fa317 100644 --- a/Changes +++ b/Changes @@ -7,6 +7,14 @@ Revision history for Perl extension Class-MOP. * Class::MOP::Class - Immutability can now be undone, added make_mutable + tests + docs (groditi) + - Massive changes to the way Immutable is done + for details see comments next to make_immutable + This fixes a bug where custom metaclasses broke + when made immutable. We are now keeping one immutable + metaclass instance per metaclass instead of just one + to prevent isa hierarchy corruption. Memory use will go + up, but I suspect it will be neglible. + - New tests added for this behavior. (groditi) 0.38 Thurs. May 31, 2007 ~~ More documentation updates ~~ diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index cbfa745..946171b 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -9,7 +9,7 @@ use Class::MOP::Instance; use Class::MOP::Method::Wrapped; use Carp 'confess'; -use Scalar::Util 'blessed', 'reftype', 'weaken'; +use Scalar::Util 'blessed', 'reftype', 'weaken', 'refaddr'; use Sub::Name 'subname'; use B 'svref_2object'; @@ -741,6 +741,23 @@ sub find_attribute_by_name { sub is_mutable { 1 } sub is_immutable { 0 } +#Why I changed this (groditi) +# - One Metaclass may have many Classes through many Metaclass instances +# - One Metaclass should only have one Immutable Metaclass instance +# - Each Class may have different Immutabilizing options +# - Therefore each Metaclass instance may have different Immutabilizing options +# - We need to store one Immutable Metaclass instance per Metaclass +# - We need to store one set of Immutable Metaclass options per Class +# - Upon make_mutable we may delete the Immutabilizing options +# - We could clean the immutable Metaclass instance when there is no more +# immutable Classes with this Metaclass, but we can also keep it in case +# another class with this same Metaclass becomes immutable. It is a case +# of trading of storing an instance to avoid unnecessary instantiations of +# Immutable Metaclass instances. You may view this as a memory leak, however +# Because we have few Metaclasses, in practice it seems acceptable +# - To allow Immutable Metaclass instances to be cleaned up we could weaken +# the reference stored in $IMMUTABLE_METACLASSES{$class} and ||= should DWIM + { # NOTE: # the immutable version of a @@ -748,13 +765,14 @@ sub is_immutable { 0 } # really class-level data so # we don't want to regenerate # it any more than we need to - my $IMMUTABLE_METACLASS; + my %IMMUTABLE_METACLASSES; my %IMMUTABLE_OPTIONS; sub make_immutable { my $self = shift; - %IMMUTABLE_OPTIONS = @_; + my %options = @_; + my $class = blessed $self || $self;; - $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, { + $IMMUTABLE_METACLASSES{$class} ||= Class::MOP::Immutable->new($self, { read_only => [qw/superclasses/], cannot_call => [qw/ add_method @@ -773,13 +791,22 @@ sub is_immutable { 0 } } }); - $IMMUTABLE_METACLASS->make_metaclass_immutable($self, %IMMUTABLE_OPTIONS); + $IMMUTABLE_METACLASSES{$class}->make_metaclass_immutable($self, %options); + $IMMUTABLE_OPTIONS{refaddr $self} = + { %options, IMMUTABLE_METACLASS => $IMMUTABLE_METACLASSES{$class} }; + + if( exists $options{debug} && $options{debug} ){ + print STDERR "# of Metaclass options: ", keys %IMMUTABLE_OPTIONS; + print STDERR "# of Immutable metaclasses: ", keys %IMMUTABLE_METACLASSES; + } } sub make_mutable{ my $self = shift; return if $self->is_mutable; - $IMMUTABLE_METACLASS->make_metaclass_mutable($self, %IMMUTABLE_OPTIONS); + my $options = delete $IMMUTABLE_OPTIONS{refaddr $self}; + my $immutable_metaclass = delete $options->{IMMUTABLE_METACLASS}; + $immutable_metaclass->make_metaclass_mutable($self, %$options); } } diff --git a/lib/Class/MOP/Immutable.pm b/lib/Class/MOP/Immutable.pm index 1d91c8d..0644666 100644 --- a/lib/Class/MOP/Immutable.pm +++ b/lib/Class/MOP/Immutable.pm @@ -85,7 +85,6 @@ sub make_metaclass_immutable { if ($options{inline_constructor}) { my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor'; - $metaclass->add_method( $options{constructor_name}, $constructor_class->new( diff --git a/t/071_immutable_w_custom_metaclass.t b/t/071_immutable_w_custom_metaclass.t index 7624b6b..598c600 100644 --- a/t/071_immutable_w_custom_metaclass.t +++ b/t/071_immutable_w_custom_metaclass.t @@ -3,39 +3,60 @@ use strict; use warnings; -use Test::More tests => 2; +use FindBin; +use File::Spec::Functions; + +use Test::More tests => 10; use Test::Exception; +use Scalar::Util; BEGIN { use_ok('Class::MOP'); } +use lib catdir($FindBin::Bin, 'lib'); + { - package Meta::Baz; + package Foo; + use strict; use warnings; - use base 'Class::MOP::Class'; -} + use metaclass; + + __PACKAGE__->meta->make_immutable; -{ package Bar; - + use strict; use warnings; - use metaclass; - + use metaclass; + __PACKAGE__->meta->make_immutable; - + package Baz; - + use strict; use warnings; - use metaclass 'Meta::Baz'; + use metaclass 'MyMetaClass'; + + sub mymetaclass_attributes{ + shift->meta->mymetaclass_attributes; + } ::lives_ok { - Baz->meta->superclasses('Bar'); + Baz->meta->superclasses('Bar'); } '... we survive the metaclass incompatability test'; } - - +{ + my $meta = Baz->meta; + is(Foo->meta->blessed, Bar->meta->blessed, 'Foo and Bar immutable metaclasses match'); + is($meta->blessed, 'MyMetaClass', 'Baz->meta blessed as MyMetaClass'); + ok(Baz->can('mymetaclass_attributes'), '... Baz can do method before immutable'); + ok($meta->can('mymetaclass_attributes'), '... meta can do method before immutable'); + $meta->make_immutable; + isa_ok($meta, 'MyMetaClass', 'Baz->meta'); + ok(Baz->can('mymetaclass_attributes'), '... Baz can do method after imutable'); + ok($meta->can('mymetaclass_attributes'), '... meta can do method after immutable'); + isnt(Baz->meta->blessed, Bar->meta->blessed, 'Baz and Bar immutable metaclasses are different'); +} diff --git a/t/073_make_mutable.t b/t/073_make_mutable.t index 118bcaf..9cf77dd 100644 --- a/t/073_make_mutable.t +++ b/t/073_make_mutable.t @@ -47,12 +47,12 @@ BEGIN { is($meta->name, 'Baz', '... checking the Baz metaclass'); my @orig_keys = sort keys %$meta; - lives_ok {$meta->make_immutable() } '... changed Baz to be immutable'; + lives_ok {$meta->make_immutable; } '... changed Baz to be immutable'; ok(!$meta->is_mutable, '... our class is no longer mutable'); ok($meta->is_immutable, '... our class is now immutable'); ok(!$meta->make_immutable, '... make immutable now returns nothing'); - lives_ok { $meta->make_mutable() } '... changed Baz to be mutable'; + lives_ok { $meta->make_mutable; } '... changed Baz to be mutable'; ok($meta->is_mutable, '... our class is mutable'); ok(!$meta->is_immutable, '... our class is not immutable'); ok(!$meta->make_mutable, '... make mutable now returns nothing'); @@ -118,13 +118,12 @@ BEGIN { class_precedence_list get_method_map ); } - - { my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); my @orig_keys = sort keys %$meta; - my @orig_meths = sort $meta->compute_all_applicable_methods; + my @orig_meths = sort { $a->{name} cmp $b->{name} } + $meta->compute_all_applicable_methods; ok($meta->is_anon_class, 'We have an anon metaclass'); lives_ok {$meta->make_immutable( inline_accessor => 1, @@ -144,7 +143,8 @@ BEGIN { my $instance = $meta->new_object; my @new_keys = sort keys %$meta; - my @new_meths = sort $meta->compute_all_applicable_methods; + my @new_meths = sort { $a->{name} cmp $b->{name} } + $meta->compute_all_applicable_methods; is_deeply(\@orig_keys, \@new_keys, '... no straneous hashkeys'); is_deeply(\@orig_meths, \@new_meths, '... no straneous methods'); diff --git a/t/lib/MyMetaClass.pm b/t/lib/MyMetaClass.pm index 7638ace..0c060cd 100644 --- a/t/lib/MyMetaClass.pm +++ b/t/lib/MyMetaClass.pm @@ -6,4 +6,10 @@ use warnings; use base 'Class::MOP::Class'; +sub mymetaclass_attributes{ + my $self = shift; + return grep { $_->isa("MyMetaClass::Attribute") } + $self->compute_all_applicable_attributes; +} + 1;