From: Guillermo Roditi Date: Sat, 2 Jun 2007 21:34:02 +0000 (+0000) Subject: more immutable fixes X-Git-Tag: 0_39~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d9586da28fb2fc6d6693edbe2e8ad4c0a8b7e50c;p=gitmo%2FClass-MOP.git more immutable fixes --- diff --git a/Changes b/Changes index 59fa317..4b4375f 100644 --- a/Changes +++ b/Changes @@ -3,6 +3,9 @@ Revision history for Perl extension Class-MOP. * Class::MOP::Class::Immutable - added make_metaclass_mutable + docs (groditi) - removed unused variable + - added create_immutable_transformer + necessary for sane overloading of immutable behavior + - tests for this (groditi) * Class::MOP::Class - Immutability can now be undone, diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 946171b..7950997 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -743,61 +743,39 @@ 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 +# - One Metaclass should only have one Immutable Transformer 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 +# - We need to store one Immutable Transformer instance per Metaclass +# - We need to store one set of Immutable Transformer 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 +# - We could clean the immutable Transformer instance when there is no more +# immutable Classes of that type, 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 +# Immutable Transformers. 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 +# - To allow Immutable Transformers instances to be cleaned up we could weaken +# the reference stored in $IMMUTABLE_TRANSFORMERS{$class} and ||= should DWIM { - # 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_METACLASSES; + my %IMMUTABLE_TRANSFORMERS; my %IMMUTABLE_OPTIONS; sub make_immutable { my $self = shift; my %options = @_; - my $class = blessed $self || $self;; - - $IMMUTABLE_METACLASSES{$class} ||= 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 - /], - memoize => { - class_precedence_list => 'ARRAY', - compute_all_applicable_attributes => 'ARRAY', - get_meta_instance => 'SCALAR', - get_method_map => 'SCALAR', - } - }); - - $IMMUTABLE_METACLASSES{$class}->make_metaclass_immutable($self, %options); + my $class = blessed $self || $self; + + $IMMUTABLE_TRANSFORMERS{$class} ||= $self->create_immutable_transformer; + my $transformer = $IMMUTABLE_TRANSFORMERS{$class}; + + $transformer->make_metaclass_immutable($self, %options); $IMMUTABLE_OPTIONS{refaddr $self} = - { %options, IMMUTABLE_METACLASS => $IMMUTABLE_METACLASSES{$class} }; + { %options, IMMUTABLE_TRANSFORMER => $transformer }; if( exists $options{debug} && $options{debug} ){ - print STDERR "# of Metaclass options: ", keys %IMMUTABLE_OPTIONS; - print STDERR "# of Immutable metaclasses: ", keys %IMMUTABLE_METACLASSES; + print STDERR "# of Metaclass options: ", keys %IMMUTABLE_OPTIONS; + print STDERR "# of Immutable transformers: ", keys %IMMUTABLE_TRANSFORMERS; } } @@ -805,10 +783,33 @@ sub is_immutable { 0 } my $self = shift; return if $self->is_mutable; my $options = delete $IMMUTABLE_OPTIONS{refaddr $self}; - my $immutable_metaclass = delete $options->{IMMUTABLE_METACLASS}; - $immutable_metaclass->make_metaclass_mutable($self, %$options); + confess "unable to find immutabilizing options" unless $options; + my $transformer = delete $options->{IMMUTABLE_TRANSFORMER}; + $transformer->make_metaclass_mutable($self, %$options); } +} +sub create_immutable_transformer { + my $self = shift; + my $class = 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 + /], + memoize => { + class_precedence_list => 'ARRAY', + compute_all_applicable_attributes => 'ARRAY', + get_meta_instance => 'SCALAR', + get_method_map => 'SCALAR', + } + }); + return $class; } 1; diff --git a/lib/Class/MOP/Immutable.pm b/lib/Class/MOP/Immutable.pm index 0644666..1d530e5 100644 --- a/lib/Class/MOP/Immutable.pm +++ b/lib/Class/MOP/Immutable.pm @@ -47,7 +47,9 @@ sub create_immutable_metaclass { ); } + my %DEFAULT_METHODS = ( + # I don't really understand this, but removing it breaks tests (groditi) meta => sub { my $self = shift; # if it is not blessed, then someone is asking @@ -57,9 +59,9 @@ my %DEFAULT_METHODS = ( # which has been made immutable, which is itself return $self; }, - is_mutable => sub { 0 }, - is_immutable => sub { 1 }, - make_immutable => sub { ( ) }, + is_mutable => sub { 0 }, + is_immutable => sub { 1 }, + make_immutable => sub { () }, ); # NOTE: diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 06ae7f0..33a2f4a 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 193; +use Test::More tests => 195; use Test::Exception; BEGIN { @@ -72,7 +72,7 @@ my @class_mop_class_methods = qw( has_attribute get_attribute add_attribute remove_attribute get_attribute_list get_attribute_map compute_all_applicable_attributes find_attribute_by_name - is_mutable is_immutable make_mutable make_immutable + is_mutable is_immutable make_mutable make_immutable create_immutable_transformer DESTROY ); diff --git a/t/070_immutable_metaclass.t b/t/070_immutable_metaclass.t index b0294be..c88d914 100644 --- a/t/070_immutable_metaclass.t +++ b/t/070_immutable_metaclass.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 73; +use Test::More tests => 83; use Test::Exception; BEGIN { @@ -41,6 +41,35 @@ BEGIN { } { + my $meta = Foo->meta; + + my $transformer; + lives_ok{ $transformer = $meta->create_immutable_transformer } + "Created immutable transformer"; + isa_ok($transformer, 'Class::MOP::Immutable', '... transformer isa Class::MOP::Immutable'); + my $methods = $transformer->create_methods_for_immutable_metaclass; + + my $immutable_metaclass = $transformer->immutable_metaclass; + is($transformer->metaclass, $meta, '... transformer has correct metaclass'); + ok($immutable_metaclass->is_anon_class, '... immutable_metaclass is an anonymous class'); + + #I don't understand why i need to ->meta here... + my $obj = $immutable_metaclass->name; + ok(!$obj->is_mutable, '... immutable_metaclass is not mutable'); + ok($obj->is_immutable, '... immutable_metaclass is immutable'); + ok(!$obj->make_immutable, '... immutable_metaclass make_mutable is noop'); + is($obj->meta, $immutable_metaclass, '... immutable_metaclass meta hack works'); + + is_deeply( + [ $immutable_metaclass->superclasses ], + [ $meta->blessed ], + '... immutable_metaclass superclasses are correct' + ); + ok($immutable_metaclass->has_method('get_mutable_metaclass_name')); + +} + +{ my $meta = Foo->meta; is($meta->name, 'Foo', '... checking the Foo metaclass'); diff --git a/t/071_immutable_w_custom_metaclass.t b/t/071_immutable_w_custom_metaclass.t index 598c600..4d2eba0 100644 --- a/t/071_immutable_w_custom_metaclass.t +++ b/t/071_immutable_w_custom_metaclass.t @@ -6,7 +6,7 @@ use warnings; use FindBin; use File::Spec::Functions; -use Test::More tests => 10; +use Test::More tests => 15; use Test::Exception; use Scalar::Util; @@ -50,13 +50,17 @@ use lib catdir($FindBin::Bin, 'lib'); { my $meta = Baz->meta; + ok($meta->is_mutable, '... Baz is mutable'); 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; + lives_ok { $meta->make_immutable } "Baz is now immutable"; + ok($meta->is_immutable, '... Baz is 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'); + lives_ok { $meta->make_mutable } "Baz is now mutable"; + ok($meta->is_mutable, '... Baz is mutable again'); } diff --git a/t/073_make_mutable.t b/t/073_make_mutable.t index 9cf77dd..bc83ae6 100644 --- a/t/073_make_mutable.t +++ b/t/073_make_mutable.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 101; +use Test::More tests => 104; use Test::Exception; use Scalar::Util; @@ -120,11 +120,15 @@ BEGIN { { + ok(Baz->meta->is_immutable, 'Superclass is immutable'); my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); my @orig_keys = sort keys %$meta; my @orig_meths = sort { $a->{name} cmp $b->{name} } $meta->compute_all_applicable_methods; ok($meta->is_anon_class, 'We have an anon metaclass'); + ok($meta->is_mutable, '... our anon class is mutable'); + ok(!$meta->is_immutable, '... our anon class is not immutable'); + lives_ok {$meta->make_immutable( inline_accessor => 1, inline_destructor => 0,