From: Yuval Kogman Date: Sat, 18 Apr 2009 22:44:24 +0000 (+0200) Subject: Remove immutable transformer X-Git-Tag: 0.82_01~11^2~8 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f5d080227b5fe6c95712defbf9212e94673ad4d2;p=gitmo%2FClass-MOP.git Remove immutable transformer --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index e8d3e63..087c8cd 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -17,8 +17,6 @@ use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; -use Class::MOP::Immutable; - BEGIN { *IS_RUNNING_ON_5_10 = ($] < 5.009_005) ? sub () { 0 } @@ -351,12 +349,37 @@ Class::MOP::Class->meta->add_attribute( ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('immutable_transformer' => ( + Class::MOP::Attribute->new('immutable_trait' => ( + reader => { + 'immutable_trait' => \&Class::MOP::Class::immutable_trait + }, + default => "Class::MOP::Class::Immutable::Trait", + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('constructor_name' => ( reader => { - 'immutable_transformer' => \&Class::MOP::Class::immutable_transformer + 'constructor_name' => \&Class::MOP::Class::constructor_name, }, - writer => { - '_set_immutable_transformer' => \&Class::MOP::Class::_set_immutable_transformer + default => "new", + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('constructor_class' => ( + reader => { + 'constructor_class' => \&Class::MOP::Class::constructor_class, + }, + default => "Class::MOP::Method::Constructor", + )) +); + + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('destructor_class' => ( + reader => { + 'destructor_class' => \&Class::MOP::Class::destructor_class, }, )) ); @@ -648,6 +671,7 @@ $_->meta->make_immutable( Class::MOP::Package Class::MOP::Module Class::MOP::Class + Class::MOP::Class::Immutable::Trait Class::MOP::Attribute Class::MOP::Method diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index ea3f371..b560beb 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -4,9 +4,11 @@ package Class::MOP::Class; use strict; use warnings; -use Class::MOP::Immutable; use Class::MOP::Instance; use Class::MOP::Method::Wrapped; +use Class::MOP::Method::Accessor; +use Class::MOP::Method::Constructor; +use Class::MOP::Class::Immutable; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; @@ -129,14 +131,14 @@ sub _new { 'methods' => {}, 'attributes' => {}, - 'attribute_metaclass' => $options->{'attribute_metaclass'} - || 'Class::MOP::Attribute', - 'method_metaclass' => $options->{'method_metaclass'} - || 'Class::MOP::Method', - 'wrapped_method_metaclass' => $options->{'wrapped_method_metaclass'} - || 'Class::MOP::Method::Wrapped', - 'instance_metaclass' => $options->{'instance_metaclass'} - || 'Class::MOP::Instance', + 'attribute_metaclass' => ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ), + 'method_metaclass' => ( $options->{'method_metaclass'} || 'Class::MOP::Method' ), + 'wrapped_method_metaclass' => ( $options->{'wrapped_method_metaclass'} || 'Class::MOP::Method::Wrapped' ), + 'instance_metaclass' => ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ), + 'immutable_trait' => ( $options->{'immutable_trait'} || 'Class::MOP::Class::Immutable::Trait' ), + 'constructor_name' => ( $options->{constructor_name} || 'new' ), + 'constructor_class' => ( $options->{constructor_class} || 'Class::MOP::Method::Constructor' ), + 'destructor_class' => $options->{destructor_class}, }, $class; } @@ -326,6 +328,10 @@ sub attribute_metaclass { $_[0]->{'attribute_metaclass'} } sub method_metaclass { $_[0]->{'method_metaclass'} } sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} } sub instance_metaclass { $_[0]->{'instance_metaclass'} } +sub immutable_trait { $_[0]->{'immutable_trait'} } +sub constructor_class { $_[0]->{'constructor_class'} } +sub constructor_name { $_[0]->{'constructor_name'} } +sub destructor_class { $_[0]->{'destructor_class'} } # Instance Construction & Cloning @@ -966,88 +972,192 @@ sub is_pristine { sub is_mutable { 1 } sub is_immutable { 0 } - -sub immutable_transformer { $_[0]->{immutable_transformer} } -sub _set_immutable_transformer { $_[0]->{immutable_transformer} = $_[1] } +sub immutable_transformer { return } + +sub _immutable_options { + my ( $self, @args ) = @_; + + return ( + inline_accessors => 1, + inline_constructor => 1, + inline_destructor => 0, + debug => 0, + immutable_trait => $self->immutable_trait, + constructor_name => $self->constructor_name, + constructor_class => $self->constructor_class, + destructor_class => $self->destructor_class, + @args, + ); +} sub make_immutable { - my $self = shift; + my ( $self, @args ) = @_; - return if $self->is_immutable; + if ( $self->is_mutable ) { + $self->_initialize_immutable($self->_immutable_options(@args)); + $self->_rebless_as_immutable(@args); + return $self; + } else { + return; + } +} - my $transformer = $self->immutable_transformer - || $self->_make_immutable_transformer(@_); - $self->_set_immutable_transformer($transformer); +sub make_mutable { + my $self = shift; - $transformer->make_metaclass_immutable; + if ( $self->is_immutable ) { + my @args = $self->immutable_options; + $self->_rebless_as_mutable(); + $self->_remove_inlined_code(@args); + delete $self->{__immutable}; + return $self; + } else { + return; + } } -{ - 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', - # FIXME perl 5.10 memoizes this on its own, no need? - linearized_isa => 'ARRAY', - get_all_methods => 'ARRAY', - get_all_method_names => 'ARRAY', - get_all_attributes => 'ARRAY', - get_meta_instance => 'SCALAR', - get_method_map => 'SCALAR', - }, +sub immutable_metaclass { + my ( $self, %args ) = @_; - # NOTE: - # this is ugly, but so are typeglobs, - # so whattayahgonnadoboutit - # - SL - 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'; - - # This is a workaround for a bug in 5.8.1 which thinks that - # goto $original->body - # is trying to go to a label - my $body = $original->body; - goto $body; - }, - }, - ); + if ( my $class = $args{immutable_metaclass} ) { + return $class; + } - sub _default_immutable_transformer_options { - return %Default_Immutable_Options; + my $trait = $args{immutable_trait} = $self->immutable_trait + || confess "no immutable trait specified for $self"; + + my $class = "Class::MOP::Class::Immutable::" . ref($self); + + if ( Class::MOP::is_class_loaded($class) ) { + return $class; + } else { + my $meta = Class::MOP::Class->initialize($class); + + $meta->superclasses( $trait, ref($self) ); + + $meta->make_immutable; + + return $class; } } -sub _make_immutable_transformer { +sub _rebless_as_immutable { + my ( $self, @args ) = @_; + + $self->{__immutable}{original_class} = ref $self; + + bless $self => $self->immutable_metaclass(@args); +} + +sub _remove_inlined_code { my $self = shift; - Class::MOP::Immutable->new( - $self, - $self->_default_immutable_transformer_options, - @_ - ); + $self->remove_method($_->name) for $self->_inlined_methods; + + delete $self->{__immutable}{inlined_methods}; } -sub make_mutable { +sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }; + +sub _add_inlined_method { + my ( $self, $method ) = @_; + + push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method; +} + +sub _initialize_immutable { + my ( $self, %args ) = @_; + + $self->{__immutable}{options} = \%args; + $self->_install_inlined_code(%args); +} + +sub _install_inlined_code { + my ( $self, %args ) = @_; + + # FIXME + $self->_inline_accessors(%args) if $args{inline_accessors}; + $self->_inline_constructor(%args) if $args{inline_constructor}; + $self->_inline_destructor(%args) if $args{inline_destructor}; +} + +sub _rebless_as_mutable { my $self = shift; - return if $self->is_mutable; + bless $self, $self->get_mutable_metaclass_name; + + return $self; +} + +sub _inline_accessors { + my $self = shift; + + foreach my $attr_name ( $self->get_attribute_list ) { + $self->get_attribute($attr_name)->install_accessors(1); + } +} + +sub _inline_constructor { + my ( $self, %args ) = @_; + + my $name = $args{constructor_name}; + + #if ( my $existing = $self->name->can($args{constructor_name}) ) { + # if ( refaddr($existing) == refaddr(\&Moose::Object::new) ) { + + unless ($args{replace_constructor} + or !$self->has_method($name) ) { + my $class = $self->name; + warn "Not inlining a constructor for $class since it defines" + . " its own constructor.\n" + . "If you are certain you don't need to inline your" + . " constructor, specify inline_constructor => 0 in your" + . " call to $class->meta->make_immutable\n"; + return; + } + + my $constructor_class = $args{constructor_class}; + + Class::MOP::load_class($constructor_class); + + my $constructor = $constructor_class->new( + options => \%args, + metaclass => $self, + is_inline => 1, + package_name => $self->name, + name => $name, + ); + + if ( $args{replace_constructor} or $constructor->can_be_inlined ) { + $self->add_method($name => $constructor); + $self->_add_inlined_method($constructor); + } +} + +sub _inline_destructor { + my ( $self, %args ) = @_; + + ( exists $args{destructor_class} ) + || confess "The 'inline_destructor' option is present, but " + . "no destructor class was specified"; + + my $destructor_class = $args{destructor_class}; + + Class::MOP::load_class($destructor_class); + + return unless $destructor_class->is_needed( $self ); + + my $destructor = $destructor_class->new( + options => \%args, + metaclass => $self, + package_name => $self->name, + name => 'DESTROY' + ); + + $self->add_method( 'DESTROY' => $destructor ); - $self->immutable_transformer->make_metaclass_mutable; + $self->_add_inlined_method($destructor); } 1; diff --git a/lib/Class/MOP/Class/Immutable/Trait.pm b/lib/Class/MOP/Class/Immutable/Trait.pm new file mode 100644 index 0000000..aaef38f --- /dev/null +++ b/lib/Class/MOP/Class/Immutable/Trait.pm @@ -0,0 +1,72 @@ +package Class::MOP::Class::Immutable::Trait; + +use strict; +use warnings; + +use MRO::Compat; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken'; + +sub meta { + my $self = shift; + + # if it is not blessed, then someone is asking + # for the meta of Class::MOP::Class:;Immutable::Trait + 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') ) { + # except this is a lie... oh well + return Class::MOP::class_of( $self->get_mutable_metaclass_name ); + } + else { + return $self; + } +} + +# the original class of the metaclass instance +sub get_mutable_metaclass_name { $_[0]{__immutable}{original_class} } + +sub immutable_options { %{ $_[0]{__immutable}{options} } } + +sub is_mutable { 0 } +sub is_immutable { 1 } + +sub superclasses { + confess "This method is read-only" if @_ > 1; + $_[0]->next::method; +} + +sub _immutable_cannot_call { Carp::confess "This method cannot be called on an immutable instance" } + +sub add_method { shift->_immutable_cannot_call } +sub alias_method { shift->_immutable_cannot_call } +sub remove_method { shift->_immutable_cannot_call } +sub add_attribute { shift->_immutable_cannot_call } +sub remove_attribute { shift->_immutable_cannot_call } +sub remove_package_symbol { shift->_immutable_cannot_call } + +sub class_precedence_list { @{ $_[0]{__immutable}{class_precedence_list} ||= [ shift->next::method ] } } +sub linearized_isa { @{ $_[0]{__immutable}{linearized_isa} ||= [ shift->next::method ] } } +sub get_all_methods { @{ $_[0]{__immutable}{get_all_methods} ||= [ shift->next::method ] } } +sub get_all_method_names { @{ $_[0]{__immutable}{get_all_method_names} ||= [ shift->next::method ] } } +sub get_all_attributes { @{ $_[0]{__immutable}{get_all_attributes} ||= [ shift->next::method ] } } + +sub get_meta_instance { $_[0]{__immutable}{get_meta_instance} ||= shift->next::method } +sub get_method_map { $_[0]{__immutable}{get_method_map} ||= shift->next::method } + +sub add_package_symbol { + confess "Cannot add package symbols to an immutable metaclass" + unless ( caller(1) )[3] eq + 'Class::MOP::Package::get_package_symbol'; + + shift->next::method(@_); +} + +1; diff --git a/lib/Class/MOP/Immutable.pm b/lib/Class/MOP/Immutable.pm deleted file mode 100644 index e1f279a..0000000 --- a/lib/Class/MOP/Immutable.pm +++ /dev/null @@ -1,533 +0,0 @@ - -package Class::MOP::Immutable; - -use strict; -use warnings; - -use Class::MOP::Method::Constructor; - -use Carp 'confess'; -use Scalar::Util 'blessed'; - -our $VERSION = '0.81'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; - -use base 'Class::MOP::Object'; - -sub new { - my ($class, @args) = @_; - - 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' => delete $options{metaclass}, - 'options' => \%options, - 'immutable_metaclass' => undef, - 'inlined_constructor' => undef, - ); - - return $self; -} - -sub _new { - my $class = shift; - my $options = @_ == 1 ? $_[0] : {@_}; - - bless $options, $class; -} - -sub immutable_metaclass { - my $self = shift; - - 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 { - my $self = shift; - - # 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, - ); -} - -sub make_metaclass_immutable { - my $self = shift; - - $self->_inline_accessors; - $self->_inline_constructor; - $self->_inline_destructor; - $self->_check_memoized_methods; - - my $metaclass = $self->metaclass; - - $metaclass->{'___original_class'} = blessed($metaclass); - bless $metaclass => $self->immutable_metaclass->name; -} - -sub _inline_accessors { - my $self = shift; - - return unless $self->options->{inline_accessors}; - - foreach my $attr_name ( $self->metaclass->get_attribute_list ) { - $self->metaclass->get_attribute($attr_name)->install_accessors(1); - } -} - -sub _inline_constructor { - my $self = shift; - - return unless $self->options->{inline_constructor}; - - unless ($self->options->{replace_constructor} - or !$self->metaclass->has_method( - $self->options->{constructor_name} - )) { - my $class = $self->metaclass->name; - warn "Not inlining a constructor for $class since it defines" - . " its own constructor.\n" - . "If you are certain you don't need to inline your" - . " constructor, specify inline_constructor => 0 in your" - . " call to $class->meta->make_immutable\n"; - return; - } - - my $constructor_class = $self->options->{constructor_class}; - - my $constructor = $constructor_class->new( - options => $self->options, - metaclass => $self->metaclass, - is_inline => 1, - package_name => $self->metaclass->name, - name => $self->options->{constructor_name}, - ); - - 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 = shift; - - return unless $self->options->{inline_destructor}; - - ( exists $self->options->{destructor_class} ) - || confess "The 'inline_destructor' option is present, but " - . "no destructor class was specified"; - - my $destructor_class = $self->options->{destructor_class}; - - return unless $destructor_class->is_needed( $self->metaclass ); - - my $destructor = $destructor_class->new( - options => $self->options, - metaclass => $self->metaclass, - package_name => $self->metaclass->name, - name => 'DESTROY' - ); - - $self->metaclass->add_method( 'DESTROY' => $destructor ); -} - -sub _check_memoized_methods { - my $self = shift; - - my $memoized_methods = $self->options->{memoize}; - foreach my $method_name ( keys %{$memoized_methods} ) { - my $type = $memoized_methods->{$method_name}; - - ( $self->metaclass->can($method_name) ) - || confess "Could not find the method '$method_name' in " - . $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 Class::MOP::class_of($self->{'___original_class'}); - } - else { - return $self; - } - }, - is_mutable => sub { 0 }, - is_immutable => sub { 1 }, - make_immutable => sub { () }, -); - -sub _create_methods_for_immutable_metaclass { - my $self = shift; - - my $metaclass = $self->metaclass; - my $meta = Class::MOP::class_of($metaclass); - - return { - %DEFAULT_METHODS, - $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 = shift; - - my $metameta = Class::MOP::class_of($self->metaclass); - - my %methods; - foreach my $read_only_method ( @{ $self->options->{read_only} } ) { - my $method = $metameta->find_method_by_name($read_only_method); - - ( defined $method ) - || confess "Could not find the method '$read_only_method' in " - . $self->metaclass->name; - - $methods{$read_only_method} = sub { - confess "This method is read-only" if scalar @_ > 1; - goto &{ $method->body }; - }; - } - - return %methods; -} - -sub _make_uncallable_methods { - my $self = shift; - - my %methods; - foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) { - $methods{$cannot_call_method} = sub { - confess - "This method ($cannot_call_method) cannot be called on an immutable instance"; - }; - } - - return %methods; -} - -sub _make_memoized_methods { - my $self = shift; - - my %methods; - - my $metameta = Class::MOP::class_of($self->metaclass); - - 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 = $metameta->find_method_by_name($method_name); - - if ( $type eq 'ARRAY' ) { - $methods{$method_name} = sub { - @{ $_[0]->{$key} } = $method->execute( $_[0] ) - if !exists $_[0]->{$key}; - return @{ $_[0]->{$key} }; - }; - } - elsif ( $type eq 'HASH' ) { - $methods{$method_name} = sub { - %{ $_[0]->{$key} } = $method->execute( $_[0] ) - if !exists $_[0]->{$key}; - return %{ $_[0]->{$key} }; - }; - } - elsif ( $type eq 'SCALAR' ) { - $methods{$method_name} = sub { - $_[0]->{$key} = $method->execute( $_[0] ) - if !exists $_[0]->{$key}; - return $_[0]->{$key}; - }; - } - } - - return %methods; -} - -sub _make_wrapped_methods { - my $self = shift; - - my %methods; - - my $wrapped_methods = $self->options->{wrapped}; - - my $metameta = Class::MOP::class_of($self->metaclass); - - foreach my $method_name ( keys %{$wrapped_methods} ) { - my $method = $metameta->find_method_by_name($method_name); - - ( defined $method ) - || confess "Could not find the method '$method_name' in " - . $self->metaclass->name; - - my $wrapper = $wrapped_methods->{$method_name}; - - $methods{$method_name} = sub { $wrapper->( $method, @_ ) }; - } - - return %methods; -} - -sub make_metaclass_mutable { - my $self = shift; - - my $metaclass = $self->metaclass; - - 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} ) { - my $type = $memoized_methods->{$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 ( $self->options->{inline_destructor} - && $metaclass->has_method('DESTROY') ) { - $metaclass->remove_method('DESTROY') - if blessed( $metaclass->get_method('DESTROY') ) eq - $self->options->{destructor_class}; - } - - # NOTE: - # 14:01 <@stevan> nah,. you shouldnt - # 14:01 <@stevan> they are just inlined - # 14:01 <@stevan> which is the default in Moose anyway - # 14:02 <@stevan> and adding new attributes will just DWIM - # 14:02 <@stevan> and you really cant change an attribute anyway - # if ($options{inline_accessors}) { - # foreach my $attr_name ($immutable->get_attribute_list) { - # my $attr = $immutable->get_attribute($attr_name); - # $attr->remove_accessors; - # $attr->install_accessors(0); - # } - # } - - # 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 ( $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; - } - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses - -=head1 SYNOPSIS - - use Class::MOP::Immutable; - - my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, { - 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', - get_all_attributes => 'ARRAY', - get_meta_instance => 'SCALAR', - get_method_map => 'SCALAR', - } - }); - - $immutable_metaclass->make_metaclass_immutable; - -=head1 DESCRIPTION - -This class encapsulates the logic behind immutabilization. - -This class provides generic immutabilization logic. Decisions about -I gets transformed are up to the caller. - -Immutabilization allows for a number of transformations. It can ask -the calling metaclass to inline methods such as the constructor, -destructor, or accessors. It can memoize metaclass accessors -themselves. It can also turn read-write accessors in the metaclass -into read-only methods, and make attempting to set these values an -error. Finally, it can make some methods throw an exception when they -are called. This is used to disable methods that can alter the class. - -=head1 METHODS - -=over 4 - -=item B<< Class::MOP::Immutable->new($metaclass, %options) >> - -This method takes a metaclass object (typically a L -object) and a hash of options. - -It returns a new transformer, but does not actually do any -transforming yet. - -This method accepts the following options: - -=over 8 - -=item * inline_accessors - -=item * inline_constructor - -=item * inline_destructor - -These are all booleans indicating whether the specified method(s) -should be inlined. - -By default, accessors and the constructor are inlined, but not the -destructor. - -=item * replace_constructor - -This is a boolean indicating whether an existing constructor should be -replaced when inlining a constructor. This defaults to false. - -=item * constructor_name - -This is the constructor method name. This defaults to "new". - -=item * constructor_class - -The name of the method metaclass for constructors. It will be used to -generate the inlined constructor. This defaults to -"Class::MOP::Method::Constructor". - -=item * destructor_class - -The name of the method metaclass for destructors. It will be used to -generate the inlined destructor. This defaults to -"Class::MOP::Method::Denstructor". - -=item * memoize - -This option takes a hash reference. They keys are method names to be -memoized, and the values are the type of data the method returns. This -can be one of "SCALAR", "ARRAY", or "HASH". - -=item * read_only - -This option takes an array reference of read-write methods which will -be made read-only. After they are transformed, attempting to set them -will throw an error. - -=item * cannot_call - -This option takes an array reference of methods which cannot be called -after immutabilization. Attempting to call these methods will throw an -error. - -=item * wrapped - -This option takes a hash reference. The keys are method names and the -body is a subroutine reference which will wrap the named method. This -allows you to do some sort of custom transformation to a method. - -=back - -=item B<< $transformer->options >> - -Returns a hash reference of the options passed to C. - -=item B<< $transformer->metaclass >> - -Returns the metaclass object passed to C. - -=item B<< $transformer->immutable_metaclass >> - -Returns the immutable metaclass object that is created by the -transformation process. - -=item B<< $transformer->inlined_constructor >> - -If the constructor was inlined, this returns the constructor method -object that was created to do this. - -=item B<< $transformer->make_metaclass_immutable >> - -Makes the transformer's metaclass immutable. - -=item B<< $transformer->make_metaclass_mutable >> - -Makes the transformer's metaclass mutable. - -=back - -=head1 AUTHORS - -Stevan Little Estevan@iinteractive.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2006-2009 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/t/000_load.t b/t/000_load.t index a69ba3a..7be801d 100644 --- a/t/000_load.t +++ b/t/000_load.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 42; +use Test::More tests => 45; BEGIN { use_ok('Class::MOP'); @@ -21,9 +21,6 @@ BEGIN { # make sure we are tracking metaclasses correctly -my @CLASS_MOP_CLASS_IMMUTABLE_CLASSES - = map { 'Class::MOP::Class::__ANON__::SERIAL::' . $_ } 1..11; - my %METAS = ( 'Class::MOP::Attribute' => Class::MOP::Attribute->meta, 'Class::MOP::Method::Generated' => Class::MOP::Method::Generated->meta, @@ -37,6 +34,8 @@ my %METAS = ( 'Class::MOP::Method::Wrapped' => Class::MOP::Method::Wrapped->meta, 'Class::MOP::Instance' => Class::MOP::Instance->meta, 'Class::MOP::Object' => Class::MOP::Object->meta, + 'Class::MOP::Class::Immutable::Trait' => Class::MOP::Class::Immutable::Trait->meta, + 'Class::MOP::Class::Immutable::Class::MOP::Class' => Class::MOP::Class::Immutable::Class::MOP::Class->meta, ); ok( Class::MOP::is_class_loaded($_), '... ' . $_ . ' is loaded' ) @@ -47,10 +46,7 @@ ok( $_->is_immutable(), '... ' . $_->name . ' is immutable' ) is_deeply( {Class::MOP::get_all_metaclasses}, - { - %METAS, - map { $_ => $_->meta } @CLASS_MOP_CLASS_IMMUTABLE_CLASSES - }, + \%METAS, '... got all the metaclasses' ); @@ -61,7 +57,8 @@ is_deeply( [ Class::MOP::Attribute->meta, Class::MOP::Class->meta, - ( map { $_->meta } sort @CLASS_MOP_CLASS_IMMUTABLE_CLASSES ), + Class::MOP::Class::Immutable::Class::MOP::Class->meta, + Class::MOP::Class::Immutable::Trait->meta, Class::MOP::Instance->meta, Class::MOP::Method->meta, Class::MOP::Method::Accessor->meta, @@ -81,6 +78,8 @@ is_deeply( sort qw/ Class::MOP::Attribute Class::MOP::Class + Class::MOP::Class::Immutable::Class::MOP::Class + Class::MOP::Class::Immutable::Trait Class::MOP::Instance Class::MOP::Method Class::MOP::Method::Accessor @@ -90,47 +89,11 @@ is_deeply( Class::MOP::Module Class::MOP::Object Class::MOP::Package - /, @CLASS_MOP_CLASS_IMMUTABLE_CLASSES + /, ], '... got all the metaclass names' ); -is_deeply( - [ - map { $_->meta->identifier } - sort { $a cmp $b } Class::MOP::get_all_metaclass_names() - ], - [ - "Class::MOP::Attribute-" - . $Class::MOP::Attribute::VERSION - . "-cpan:STEVAN", - "Class::MOP::Class-" . $Class::MOP::Class::VERSION . "-cpan:STEVAN", - ( sort @CLASS_MOP_CLASS_IMMUTABLE_CLASSES ), - "Class::MOP::Instance-" - . $Class::MOP::Instance::VERSION - . "-cpan:STEVAN", - "Class::MOP::Method-" . $Class::MOP::Method::VERSION . "-cpan:STEVAN", - "Class::MOP::Method::Accessor-" - . $Class::MOP::Method::Accessor::VERSION - . "-cpan:STEVAN", - "Class::MOP::Method::Constructor-" - . $Class::MOP::Method::Constructor::VERSION - . "-cpan:STEVAN", - "Class::MOP::Method::Generated-" - . $Class::MOP::Method::Generated::VERSION - . "-cpan:STEVAN", - "Class::MOP::Method::Wrapped-" - . $Class::MOP::Method::Wrapped::VERSION - . "-cpan:STEVAN", - "Class::MOP::Module-" . $Class::MOP::Module::VERSION . "-cpan:STEVAN", - "Class::MOP::Object-" . $Class::MOP::Object::VERSION . "-cpan:STEVAN", - "Class::MOP::Package-" - . $Class::MOP::Package::VERSION - . "-cpan:STEVAN", - ], - '... got all the metaclass identifiers' -); - # testing the meta-circularity of the system is( diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 1e35255..48fd708 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 262; +use Test::More tests => 294; use Test::Exception; use Class::MOP; @@ -84,9 +84,14 @@ my @class_mop_class_methods = qw( 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 - immutable_transformer _set_immutable_transformer - _make_immutable_transformer - _default_immutable_transformer_options + _initialize_immutable _install_inlined_code _inlined_methods + _add_inlined_method _inline_accessors _inline_constructor + _inline_destructor _immutable_options _rebless_as_immutable + _rebless_as_mutable _remove_inlined_code + + immutable_metaclass immutable_trait constructor_name constructor_class destructor_class + + immutable_transformer DESTROY ); @@ -165,7 +170,10 @@ my @class_mop_class_attributes = ( 'method_metaclass', 'wrapped_method_metaclass', 'instance_metaclass', - 'immutable_transformer', + 'immutable_trait', + 'constructor_name', + 'constructor_class', + 'destructor_class', ); # check class diff --git a/t/070_immutable_metaclass.t b/t/070_immutable_metaclass.t index 2741363..b2ee906 100644 --- a/t/070_immutable_metaclass.t +++ b/t/070_immutable_metaclass.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 80; +use Test::More tests => 75; use Test::Exception; use Class::MOP; @@ -42,20 +42,11 @@ use Class::MOP; $meta->make_immutable; - my $transformer = $meta->immutable_transformer; - isa_ok( $transformer, 'Class::MOP::Immutable', - '... transformer isa Class::MOP::Immutable' ); - - my $immutable_metaclass = $transformer->immutable_metaclass; - is( $transformer->metaclass, $meta, - '... transformer has correct metaclass' ); - ok( $transformer->inlined_constructor, - '... transformer says it did inline the constructor' ); - ok( $immutable_metaclass->is_anon_class, - '... immutable_metaclass is an anonymous class' ); + my $immutable_metaclass = $meta->immutable_metaclass->meta; #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, @@ -63,15 +54,8 @@ use Class::MOP; is( $obj->meta, $immutable_metaclass, '... immutable_metaclass meta hack works' ); - is_deeply( - [ $immutable_metaclass->superclasses ], - [ $original_metaclass_name ], - '... immutable_metaclass superclasses are correct' - ); - ok( - $immutable_metaclass->has_method('get_mutable_metaclass_name'), - 'immutable metaclass has get_mutable_metaclass_name method' - ); + isa_ok( $meta, "Class::MOP::Class::Immutable::Trait" ); + isa_ok( $meta, "Class::MOP::Class" ); } @@ -82,11 +66,6 @@ use Class::MOP; ok( !$meta->is_mutable, '... our class is not mutable' ); ok( $meta->is_immutable, '... our class is immutable' ); - my $transformer = $meta->immutable_transformer; - - is( $transformer, $meta->immutable_transformer, - '... immutable transformer cache works' ); - isa_ok( $meta, 'Class::MOP::Class' ); dies_ok { $meta->add_method() } '... exception thrown as expected'; diff --git a/t/071_immutable_w_custom_metaclass.t b/t/071_immutable_w_custom_metaclass.t index b19320d..c81abb7 100644 --- a/t/071_immutable_w_custom_metaclass.t +++ b/t/071_immutable_w_custom_metaclass.t @@ -47,10 +47,10 @@ use lib catdir( $FindBin::Bin, 'lib' ); { my $meta = Baz->meta; ok( $meta->is_mutable, '... Baz is mutable' ); - isnt( + is( Scalar::Util::blessed( Foo->meta ), Scalar::Util::blessed( Bar->meta ), - 'Foo and Bar immutable metaclasses do not match' + 'Foo and Bar immutable metaclasses match' ); is( Scalar::Util::blessed($meta), 'MyMetaClass', 'Baz->meta blessed as MyMetaClass' ); diff --git a/t/073_make_mutable.t b/t/073_make_mutable.t index 5212491..d15626e 100644 --- a/t/073_make_mutable.t +++ b/t/073_make_mutable.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 101; +use Test::More tests => 99; use Test::Exception; use Scalar::Util; @@ -44,7 +44,6 @@ use Class::MOP; 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'); @@ -52,8 +51,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->immutable_transformer->inlined_constructor, - '... transformer says it did inline the constructor'); + is_deeply([ map { $_->name } $meta->_inlined_methods ], [ 'new' ], '... really, i mean it'); lives_ok { $meta->make_mutable; } '... changed Baz to be mutable'; ok($meta->is_mutable, '... our class is mutable'); @@ -61,8 +59,6 @@ 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->immutable_transformer->inlined_constructor, - '... transformer says it did not inline the constructor'); my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); @@ -127,9 +123,7 @@ use Class::MOP; ok(Baz->meta->is_immutable, 'Superclass is immutable'); my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; - $orig_keys{immutable_transformer} = 1; - my @orig_meths = sort { $a->name cmp $b->name } - $meta->get_all_methods; + my @orig_meths = sort { $a->name cmp $b->name } $meta->get_all_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'); @@ -221,7 +215,4 @@ use Class::MOP; Foo->meta->make_immutable; Bar->meta->make_immutable; Bar->meta->make_mutable; - - 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 0897f59..31690b6 100644 --- a/xt/pod_coverage.t +++ b/xt/pod_coverage.t @@ -36,7 +36,6 @@ my %trustme = ( 'clone_instance', 'construct_class_instance', 'construct_instance', - 'create_immutable_transformer', 'create_meta_instance', 'get_immutable_options', 'reset_package_cache_flag',