use Class::MOP::Attribute;
use Class::MOP::Method;
-use Class::MOP::Immutable;
-
BEGIN {
*IS_RUNNING_ON_5_10 = ($] < 5.009_005)
? sub () { 0 }
);
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,
},
))
);
Class::MOP::Package
Class::MOP::Module
Class::MOP::Class
+ Class::MOP::Class::Immutable::Trait
Class::MOP::Attribute
Class::MOP::Method
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';
'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;
}
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
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;
--- /dev/null
+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;
+++ /dev/null
-
-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<what> 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<Class::MOP::Class>
-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<new>.
-
-=item B<< $transformer->metaclass >>
-
-Returns the metaclass object passed to C<new>.
-
-=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 E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006-2009 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
use strict;
use warnings;
-use Test::More tests => 42;
+use Test::More tests => 45;
BEGIN {
use_ok('Class::MOP');
# 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,
'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' )
is_deeply(
{Class::MOP::get_all_metaclasses},
- {
- %METAS,
- map { $_ => $_->meta } @CLASS_MOP_CLASS_IMMUTABLE_CLASSES
- },
+ \%METAS,
'... got all the metaclasses'
);
[
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,
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
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(
use strict;
use warnings;
-use Test::More tests => 262;
+use Test::More tests => 294;
use Test::Exception;
use Class::MOP;
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
);
'method_metaclass',
'wrapped_method_metaclass',
'instance_metaclass',
- 'immutable_transformer',
+ 'immutable_trait',
+ 'constructor_name',
+ 'constructor_class',
+ 'destructor_class',
);
# check class
use strict;
use warnings;
-use Test::More tests => 80;
+use Test::More tests => 75;
use Test::Exception;
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,
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" );
}
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';
{
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' );
use strict;
use warnings;
-use Test::More tests => 101;
+use Test::More tests => 99;
use Test::Exception;
use Scalar::Util;
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');
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');
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');
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');
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' );
}
'clone_instance',
'construct_class_instance',
'construct_instance',
- 'create_immutable_transformer',
'create_meta_instance',
'get_immutable_options',
'reset_package_cache_flag',
projects / gitmo/Class-MOP.git / commitdiff