From: Dave Rolsky Date: Mon, 16 Mar 2009 19:29:45 +0000 (-0500) Subject: Major refactoring of the immutabilization code. This greatly X-Git-Tag: 0.78_02~36 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=44d6ea77ff5ddf47824a680d3fe11a2263290ed0;p=gitmo%2FClass-MOP.git Major refactoring of the immutabilization code. This greatly simplifies the APIs for making a class immutable or mutable, and also simplifies the handling of state in Class::MOP::Immutable objects. This still needs to be tested with Moose. --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 680b910..4161596 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -329,6 +329,17 @@ Class::MOP::Class->meta->add_attribute( )) ); +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('immutable_transformer' => ( + reader => { + 'immutable_transformer' => \&Class::MOP::Class::immutable_transformer + }, + writer => { + '_set_immutable_transformer' => \&Class::MOP::Class::_set_immutable_transformer + }, + )) +); + # NOTE: # we don't actually need to tie the knot with # Class::MOP::Class here, it is actually handled diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 6bc3e36..249d6a8 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -73,8 +73,7 @@ sub construct_class_instance { # now create the metaclass my $meta; if ($class eq 'Class::MOP::Class') { - no strict 'refs'; - $meta = $class->_new($options) + $meta = $class->_new($options); } else { # NOTE: @@ -973,108 +972,43 @@ sub is_pristine { sub is_mutable { 1 } sub is_immutable { 0 } -# NOTE: -# Why I changed this (groditi) -# - One Metaclass may have many Classes through many Metaclass instances -# - 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 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 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 Transformers. You may view this as a memory leak, however -# Because we have few Metaclasses, in practice it seems acceptable -# - To allow Immutable Transformers instances to be cleaned up we could weaken -# the reference stored in $IMMUTABLE_TRANSFORMERS{$class} and ||= should DWIM +sub immutable_transformer { $_[0]->{immutable_transformer} } +sub _set_immutable_transformer { $_[0]->{immutable_transformer} = $_[1] } { - - my %IMMUTABLE_TRANSFORMERS; - my %IMMUTABLE_OPTIONS; - - sub get_immutable_options { - my $self = shift; - return if $self->is_mutable; - confess "unable to find immutabilizing options" - unless exists $IMMUTABLE_OPTIONS{$self->name}; - my %options = %{$IMMUTABLE_OPTIONS{$self->name}}; - delete $options{IMMUTABLE_TRANSFORMER}; - return \%options; - } - - sub get_immutable_transformer { - my $self = shift; - if( $self->is_mutable ){ - return $IMMUTABLE_TRANSFORMERS{$self->name} ||= $self->create_immutable_transformer; - } - confess "unable to find transformer for immutable class" - unless exists $IMMUTABLE_OPTIONS{$self->name}; - return $IMMUTABLE_OPTIONS{$self->name}->{IMMUTABLE_TRANSFORMER}; - } - - sub make_immutable { - my $self = shift; - my %options = @_; - - my $transformer = $self->get_immutable_transformer; - $transformer->make_metaclass_immutable($self, \%options); - $IMMUTABLE_OPTIONS{$self->name} = - { %options, IMMUTABLE_TRANSFORMER => $transformer }; - - if( exists $options{debug} && $options{debug} ){ - print STDERR "# of Metaclass options: ", keys %IMMUTABLE_OPTIONS; - print STDERR "# of Immutable transformers: ", keys %IMMUTABLE_TRANSFORMERS; - } - - 1; - } - - sub make_mutable{ - my $self = shift; - return if $self->is_mutable; - my $options = delete $IMMUTABLE_OPTIONS{$self->name}; - confess "unable to find immutabilizing options" unless ref $options; - my $transformer = delete $options->{IMMUTABLE_TRANSFORMER}; - $transformer->make_metaclass_mutable($self, $options); - 1; - } -} - -sub create_immutable_transformer { - my $self = shift; - my $class = Class::MOP::Immutable->new($self, { + my %Default_Immutable_Options = ( read_only => [qw/superclasses/], - cannot_call => [qw/ - add_method - alias_method - remove_method - add_attribute - remove_attribute - remove_package_symbol - /], - memoize => { - class_precedence_list => 'ARRAY', - linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need? - get_all_methods => 'ARRAY', - get_all_method_names => 'ARRAY', - #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future - compute_all_applicable_attributes => 'ARRAY', - get_meta_instance => 'SCALAR', - get_method_map => 'SCALAR', + cannot_call => [ + qw/ + add_method + alias_method + remove_method + add_attribute + remove_attribute + remove_package_symbol + / + ], + memoize => { + class_precedence_list => 'ARRAY', + # FIXME perl 5.10 memoizes this on its own, no need? + linearized_isa => 'ARRAY', + get_all_methods => 'ARRAY', + get_all_method_names => 'ARRAY', + compute_all_applicable_attributes => 'ARRAY', + get_meta_instance => 'SCALAR', + get_method_map => 'SCALAR', }, + # NOTE: - # this is ugly, but so are typeglobs, + # this is ugly, but so are typeglobs, # so whattayahgonnadoboutit # - SL - wrapped => { + wrapped => { add_package_symbol => sub { my $original = shift; - confess "Cannot add package symbols to an immutable metaclass" - unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol'; + confess "Cannot add package symbols to an immutable metaclass" + unless ( caller(2) )[3] eq + 'Class::MOP::Package::get_package_symbol'; # This is a workaround for a bug in 5.8.1 which thinks that # goto $original->body @@ -1083,8 +1017,32 @@ sub create_immutable_transformer { goto $body; }, }, - }); - return $class; + ); + + sub make_immutable { + my $self = shift; + + return if $self->is_immutable; + + my $transformer = $self->immutable_transformer + || Class::MOP::Immutable->new( + $self, + %Default_Immutable_Options, + @_ + ); + + $self->_set_immutable_transformer($transformer); + + $transformer->make_metaclass_immutable; + } +} + +sub make_mutable { + my $self = shift; + + return if $self->is_mutable; + + $self->immutable_transformer->make_metaclass_mutable; } 1; @@ -1549,7 +1507,7 @@ documentation. Calling this method reverse the immutabilization transformation. -=item B<< $metaclass->get_immutable_transformer >> +=item B<< $metaclass->immutable_transformer >> If the class has been made immutable previously, this returns the L object that was created to do the diff --git a/lib/Class/MOP/Immutable.pm b/lib/Class/MOP/Immutable.pm index 7c83fc4..0231dc1 100644 --- a/lib/Class/MOP/Immutable.pm +++ b/lib/Class/MOP/Immutable.pm @@ -18,23 +18,21 @@ use base 'Class::MOP::Object'; sub new { my ($class, @args) = @_; - my ( $metaclass, $options ); - - if ( @args == 2 ) { - # compatibility args - ( $metaclass, $options ) = @args; - } else { - unshift @args, "metaclass" if @args % 2 == 1; - - # default named args - my %options = @args; - $options = \%options; - $metaclass = $options{metaclass}; - } + unshift @args, 'metaclass' if @args % 2 == 1; + + my %options = ( + inline_accessors => 1, + inline_constructor => 1, + inline_destructor => 0, + constructor_name => 'new', + constructor_class => 'Class::MOP::Method::Constructor', + debug => 0, + @args, + ); my $self = $class->_new( - 'metaclass' => $metaclass, - 'options' => $options, + 'metaclass' => delete $options{metaclass}, + 'options' => \%options, 'immutable_metaclass' => undef, 'inlined_constructor' => undef, ); @@ -52,188 +50,167 @@ sub _new { sub immutable_metaclass { my $self = shift; - $self->create_immutable_metaclass unless $self->{'immutable_metaclass'}; - - return $self->{'immutable_metaclass'}; + return $self->{'immutable_metaclass'} ||= $self->_create_immutable_metaclass; } sub metaclass { (shift)->{'metaclass'} } sub options { (shift)->{'options'} } sub inlined_constructor { (shift)->{'inlined_constructor'} } -sub create_immutable_metaclass { +sub _create_immutable_metaclass { my $self = shift; - # NOTE: - # The immutable version of the - # metaclass is just a anon-class - # which shadows the methods - # appropriately - $self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class( + # NOTE: The immutable version of the metaclass is just a + # anon-class which shadows the methods appropriately + return Class::MOP::Class->create_anon_class( superclasses => [ blessed($self->metaclass) ], - methods => $self->create_methods_for_immutable_metaclass, + methods => $self->_create_methods_for_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 - # for the meta of Class::MOP::Immutable - return Class::MOP::Class->initialize($self) unless blessed($self); - # otherwise, they are asking for the metaclass - # which has been made immutable, which is itself - # except in the cases where it is a metaclass itself - # that has been made immutable and for that we need - # to dig a bit ... - if ($self->isa('Class::MOP::Class')) { - return $self->{'___original_class'}->meta; - } - else { - return $self; - } - }, - is_mutable => sub { 0 }, - is_immutable => sub { 1 }, - make_immutable => sub { () }, -); - -# NOTE: -# this will actually convert the -# existing metaclass to an immutable -# version of itself sub make_metaclass_immutable { - my ($self, $metaclass, $options) = @_; - - my %options = ( - inline_accessors => 1, - inline_constructor => 1, - inline_destructor => 0, - constructor_name => 'new', - debug => 0, - %$options, - ); + my $self = shift; - %$options = %options; # FIXME who the hell is relying on this?!? tests fail =( + $self->_inline_accessors; + $self->_inline_constructor; + $self->_inline_destructor; + $self->_check_memoized_methods; - $self->_inline_accessors( $metaclass, \%options ); - $self->_inline_constructor( $metaclass, \%options ); - $self->_inline_destructor( $metaclass, \%options ); - $self->_check_memoized_methods( $metaclass, \%options ); + my $metaclass = $self->metaclass; $metaclass->{'___original_class'} = blessed($metaclass); bless $metaclass => $self->immutable_metaclass->name; } sub _inline_accessors { - my ( $self, $metaclass, $options ) = @_; + my $self = shift; - return unless $options->{inline_accessors}; + return unless $self->options->{inline_accessors}; - foreach my $attr_name ( $metaclass->get_attribute_list ) { - $metaclass->get_attribute($attr_name)->install_accessors(1); + foreach my $attr_name ( $self->metaclass->get_attribute_list ) { + $self->metaclass->get_attribute($attr_name)->install_accessors(1); } } sub _inline_constructor { - my ( $self, $metaclass, $options ) = @_; + my $self = shift; - return unless $options->{inline_constructor}; + return unless $self->options->{inline_constructor}; return - unless $options->{replace_constructor} - or !$metaclass->has_method( $options->{constructor_name} ); + unless $self->options->{replace_constructor} + or !$self->metaclass->has_method( + $self->options->{constructor_name} + ); - my $constructor_class = $options->{constructor_class} - || 'Class::MOP::Method::Constructor'; + my $constructor_class = $self->options->{constructor_class}; my $constructor = $constructor_class->new( - options => $options, - metaclass => $metaclass, + options => $self->options, + metaclass => $self->metaclass, is_inline => 1, - package_name => $metaclass->name, - name => $options->{constructor_name}, + package_name => $self->metaclass->name, + name => $self->options->{constructor_name}, ); - if ( $options->{replace_constructor} or $constructor->can_be_inlined ) { - $metaclass->add_method( $options->{constructor_name} => $constructor ); + if ( $self->options->{replace_constructor} + or $constructor->can_be_inlined ) { + $self->metaclass->add_method( + $self->options->{constructor_name} => $constructor ); $self->{inlined_constructor} = $constructor; } } sub _inline_destructor { - my ( $self, $metaclass, $options ) = @_; + my $self = shift; - return unless $options->{inline_destructor}; + return unless $self->options->{inline_destructor}; - ( exists $options->{destructor_class} ) + ( exists $self->options->{destructor_class} ) || confess "The 'inline_destructor' option is present, but " . "no destructor class was specified"; - my $destructor_class = $options->{destructor_class}; + my $destructor_class = $self->options->{destructor_class}; - return unless $destructor_class->is_needed($metaclass); + return unless $destructor_class->is_needed( $self->metaclass ); my $destructor = $destructor_class->new( - options => $options, - metaclass => $metaclass, - package_name => $metaclass->name, + options => $self->options, + metaclass => $self->metaclass, + package_name => $self->metaclass->name, name => 'DESTROY' ); return unless $destructor->is_needed; - $metaclass->add_method( 'DESTROY' => $destructor ) + $self->metaclass->add_method( 'DESTROY' => $destructor ); } sub _check_memoized_methods { - my ( $self, $metaclass, $options ) = @_; + my $self = shift; my $memoized_methods = $self->options->{memoize}; foreach my $method_name ( keys %{$memoized_methods} ) { my $type = $memoized_methods->{$method_name}; - ( $metaclass->can($method_name) ) + ( $self->metaclass->can($method_name) ) || confess "Could not find the method '$method_name' in " - . $metaclass->name; + . $self->metaclass->name; } } +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 + # for the meta of Class::MOP::Immutable + return Class::MOP::Class->initialize($self) unless blessed($self); + # otherwise, they are asking for the metaclass + # which has been made immutable, which is itself + # except in the cases where it is a metaclass itself + # that has been made immutable and for that we need + # to dig a bit ... + if ($self->isa('Class::MOP::Class')) { + return $self->{'___original_class'}->meta; + } + else { + return $self; + } + }, + is_mutable => sub { 0 }, + is_immutable => sub { 1 }, + make_immutable => sub { () }, +); -sub create_methods_for_immutable_metaclass { +sub _create_methods_for_immutable_metaclass { my $self = shift; - my %methods = %DEFAULT_METHODS; my $metaclass = $self->metaclass; my $meta = $metaclass->meta; - $methods{get_mutable_metaclass_name} - = sub { (shift)->{'___original_class'} }; - - $methods{immutable_transformer} = sub {$self}; - return { %DEFAULT_METHODS, - $self->_make_read_only_methods( $metaclass, $meta ), - $self->_make_uncallable_methods( $metaclass, $meta ), - $self->_make_memoized_methods( $metaclass, $meta ), - $self->_make_wrapped_methods( $metaclass, $meta ), + $self->_make_read_only_methods, + $self->_make_uncallable_methods, + $self->_make_memoized_methods, + $self->_make_wrapped_methods, get_mutable_metaclass_name => sub { (shift)->{'___original_class'} }, immutable_transformer => sub {$self}, }; } sub _make_read_only_methods { - my ( $self, $metaclass, $meta ) = @_; + my $self = shift; + + my $metameta = $self->metaclass->meta; my %methods; foreach my $read_only_method ( @{ $self->options->{read_only} } ) { - my $method = $meta->find_method_by_name($read_only_method); + my $method = $metameta->find_method_by_name($read_only_method); ( defined $method ) || confess "Could not find the method '$read_only_method' in " - . $metaclass->name; + . $self->metaclass->name; $methods{$read_only_method} = sub { confess "This method is read-only" if scalar @_ > 1; @@ -245,7 +222,7 @@ sub _make_read_only_methods { } sub _make_uncallable_methods { - my ( $self, $metaclass, $meta ) = @_; + my $self = shift; my %methods; foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) { @@ -259,15 +236,17 @@ sub _make_uncallable_methods { } sub _make_memoized_methods { - my ( $self, $metaclass, $meta ) = @_; + my $self = shift; my %methods; + my $metameta = $self->metaclass->meta; + my $memoized_methods = $self->options->{memoize}; foreach my $method_name ( keys %{$memoized_methods} ) { my $type = $memoized_methods->{$method_name}; my $key = '___' . $method_name; - my $method = $meta->find_method_by_name($method_name); + my $method = $metameta->find_method_by_name($method_name); if ( $type eq 'ARRAY' ) { $methods{$method_name} = sub { @@ -296,18 +275,20 @@ sub _make_memoized_methods { } sub _make_wrapped_methods { - my ( $self, $metaclass, $meta ) = @_; + my $self = shift; my %methods; my $wrapped_methods = $self->options->{wrapped}; + my $metameta = $self->metaclass->meta; + foreach my $method_name ( keys %{$wrapped_methods} ) { - my $method = $meta->find_method_by_name($method_name); + my $method = $metameta->find_method_by_name($method_name); ( defined $method ) || confess "Could not find the method '$method_name' in " - . $metaclass->name; + . $self->metaclass->name; my $wrapper = $wrapped_methods->{$method_name}; @@ -318,28 +299,31 @@ sub _make_wrapped_methods { } sub make_metaclass_mutable { - my ($self, $immutable, $options) = @_; + my $self = shift; - my %options = %$options; + my $metaclass = $self->metaclass; - my $original_class = $immutable->get_mutable_metaclass_name; - delete $immutable->{'___original_class'} ; - bless $immutable => $original_class; + my $original_class = $metaclass->get_mutable_metaclass_name; + delete $metaclass->{'___original_class'}; + bless $metaclass => $original_class; my $memoized_methods = $self->options->{memoize}; - foreach my $method_name (keys %{$memoized_methods}) { + foreach my $method_name ( keys %{$memoized_methods} ) { my $type = $memoized_methods->{$method_name}; - ($immutable->can($method_name)) - || confess "Could not find the method '$method_name' in " . $immutable->name; - if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) { - delete $immutable->{'___' . $method_name}; + ( $metaclass->can($method_name) ) + || confess "Could not find the method '$method_name' in " + . $metaclass->name; + if ( $type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) { + delete $metaclass->{ '___' . $method_name }; } } - if ($options{inline_destructor} && $immutable->has_method('DESTROY')) { - $immutable->remove_method('DESTROY') - if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class}; + if ( $self->options->{inline_destructor} + && $metaclass->has_method('DESTROY') ) { + $metaclass->remove_method('DESTROY') + if blessed( $metaclass->get_method('DESTROY') ) eq + $self->options->{destructor_class}; } # NOTE: @@ -359,11 +343,17 @@ sub make_metaclass_mutable { # 14:26 <@stevan> the only user of ::Method::Constructor is immutable # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi # 14:27 <@stevan> so I am not worried - if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) { - my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor'; - - if ( blessed($immutable->get_method($options{constructor_name})) eq $constructor_class ) { - $immutable->remove_method( $options{constructor_name} ); + if ( $self->options->{inline_constructor} + && $metaclass->has_method( $self->options->{constructor_name} ) ) { + my $constructor_class = $self->options->{constructor_class} + || 'Class::MOP::Method::Constructor'; + + if ( + blessed( + $metaclass->get_method( $self->options->{constructor_name} ) + ) eq $constructor_class + ) { + $metaclass->remove_method( $self->options->{constructor_name} ); $self->{inlined_constructor} = undef; } } @@ -402,7 +392,7 @@ Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses } }); - $immutable_metaclass->make_metaclass_immutable(@_) + $immutable_metaclass->make_metaclass_immutable; =head1 DESCRIPTION diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 2fee9f8..c0f4d1b 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -78,8 +78,8 @@ my @class_mop_class_methods = qw( has_attribute get_attribute add_attribute remove_attribute get_attribute_list get_attribute_map get_all_attributes compute_all_applicable_attributes find_attribute_by_name - is_mutable is_immutable make_mutable make_immutable create_immutable_transformer - get_immutable_options get_immutable_transformer + is_mutable is_immutable make_mutable make_immutable + immutable_transformer _set_immutable_transformer DESTROY ); @@ -157,7 +157,8 @@ my @class_mop_class_attributes = ( 'attribute_metaclass', 'method_metaclass', 'wrapped_method_metaclass', - 'instance_metaclass' + 'instance_metaclass', + 'immutable_transformer', ); # check class diff --git a/t/070_immutable_metaclass.t b/t/070_immutable_metaclass.t index 329b184..4ec34fc 100644 --- a/t/070_immutable_metaclass.t +++ b/t/070_immutable_metaclass.t @@ -1,13 +1,12 @@ use strict; use warnings; -use Test::More tests => 86; +use Test::More tests => 80; use Test::Exception; use Class::MOP; { - package Foo; use strict; @@ -39,19 +38,19 @@ use Class::MOP; { my $meta = Foo->meta; + my $original_metaclass_name = ref $meta; + + $meta->make_immutable; - my $transformer; - lives_ok { $transformer = $meta->create_immutable_transformer } - "Created immutable transformer"; + my $transformer = $meta->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( !$transformer->inlined_constructor, - '... transformer says it did not inline the constructor' ); + ok( $transformer->inlined_constructor, + '... transformer says it did inline the constructor' ); ok( $immutable_metaclass->is_anon_class, '... immutable_metaclass is an anonymous class' ); @@ -66,7 +65,7 @@ use Class::MOP; is_deeply( [ $immutable_metaclass->superclasses ], - [ Scalar::Util::blessed($meta) ], + [ $original_metaclass_name ], '... immutable_metaclass superclasses are correct' ); ok( @@ -80,24 +79,13 @@ use Class::MOP; my $meta = Foo->meta; is( $meta->name, 'Foo', '... checking the Foo metaclass' ); - ok( $meta->is_mutable, '... our class is mutable' ); - ok( !$meta->is_immutable, '... our class is not immutable' ); + ok( !$meta->is_mutable, '... our class is not mutable' ); + ok( $meta->is_immutable, '... our class is immutable' ); - my $transformer = $meta->get_immutable_transformer; - - lives_ok { - $meta->make_immutable(); - } - '... changed Foo to be immutable'; + my $transformer = $meta->immutable_transformer; - ok( $transformer->inlined_constructor, - '... transformer says it did inline the constructor' ); - is( $transformer, $meta->get_immutable_transformer, + is( $transformer, $meta->immutable_transformer, '... immutable transformer cache works' ); - ok( !$meta->make_immutable, '... make immutable now returns nothing' ); - - ok( !$meta->is_mutable, '... our class is no longer mutable' ); - ok( $meta->is_immutable, '... our class is now immutable' ); isa_ok( $meta, 'Class::MOP::Class' ); diff --git a/t/073_make_mutable.t b/t/073_make_mutable.t index dca59cd..1ad0c96 100644 --- a/t/073_make_mutable.t +++ b/t/073_make_mutable.t @@ -41,7 +41,10 @@ use Class::MOP; { my $meta = Baz->meta; is($meta->name, 'Baz', '... checking the Baz metaclass'); - my @orig_keys = sort grep { !/^_/ } keys %$meta; + my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + # Since this has no default it won't be present yet, but it will + # be after the class is made immutable. + $orig_keys{immutable_transformer} = 1; lives_ok {$meta->make_immutable; } '... changed Baz to be immutable'; ok(!$meta->is_mutable, '... our class is no longer mutable'); @@ -49,7 +52,7 @@ use Class::MOP; ok(!$meta->make_immutable, '... make immutable now returns nothing'); ok($meta->get_method_map->{new}, '... inlined constructor created'); ok($meta->has_method('new'), '... inlined constructor created for sure'); - ok($meta->get_immutable_transformer->inlined_constructor, + ok($meta->immutable_transformer->inlined_constructor, '... transformer says it did inline the constructor'); lives_ok { $meta->make_mutable; } '... changed Baz to be mutable'; @@ -58,11 +61,11 @@ use Class::MOP; ok(!$meta->make_mutable, '... make mutable now returns nothing'); ok(!$meta->get_method_map->{new}, '... inlined constructor removed'); ok(!$meta->has_method('new'), '... inlined constructor removed for sure'); - ok(!$meta->get_immutable_transformer->inlined_constructor, + ok(!$meta->immutable_transformer->inlined_constructor, '... transformer says it did not inline the constructor'); - my @new_keys = sort grep { !/^_/ } keys %$meta; - is_deeply(\@orig_keys, \@new_keys, '... no straneous hashkeys'); + my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); isa_ok($meta, 'Class::MOP::Class', '... Baz->meta isa Class::MOP::Class'); @@ -132,7 +135,8 @@ use Class::MOP; ok(Baz->meta->is_immutable, 'Superclass is immutable'); my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); - my @orig_keys = sort grep { !/^_/ } keys %$meta; + my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + $orig_keys{immutable_transformer} = 1; my @orig_meths = sort { $a->{name} cmp $b->{name} } $meta->compute_all_applicable_methods; ok($meta->is_anon_class, 'We have an anon metaclass'); @@ -156,11 +160,11 @@ use Class::MOP; ok($meta->is_anon_class, '... still marked as an anon class'); my $instance = $meta->new_object; - my @new_keys = sort grep { !/^_/ } keys %$meta; + my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; 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'); + is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); + is_deeply(\@orig_meths, \@new_meths, '... no extraneous methods'); isa_ok($meta, 'Class::MOP::Class', '... Anon class isa Class::MOP::Class'); @@ -232,6 +236,6 @@ use Class::MOP; Bar->meta->make_immutable; Bar->meta->make_mutable; - isnt( Foo->meta->get_immutable_transformer, Bar->meta->get_immutable_transformer, + isnt( Foo->meta->immutable_transformer, Bar->meta->immutable_transformer, 'Foo and Bar should have different immutable transformer objects' ); } diff --git a/xt/pod_coverage.t b/xt/pod_coverage.t index fb79eb1..70e6585 100644 --- a/xt/pod_coverage.t +++ b/xt/pod_coverage.t @@ -45,13 +45,6 @@ my %trustme = ( 'compute_all_applicable_attributes', ], - - 'Class::MOP::Immutable' => [ - qw( create_immutable_metaclass - create_methods_for_immutable_metaclass - make_metaclass_immutable - make_metaclass_mutable ) - ], ); for my $module ( sort @modules ) {