use Class::MOP::Attribute;
use Class::MOP::Method;
- use Class::MOP::Immutable;
-
BEGIN {
*IS_RUNNING_ON_5_10 = ($] < 5.009_005)
? sub () { 0 }
*check_package_cache_flag = \&mro::get_pkg_gen;
}
-our $VERSION = '0.81';
+our $VERSION = '0.82';
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
);
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 => {
+ 'constructor_name' => \&Class::MOP::Class::constructor_name,
+ },
+ default => "new",
+ ))
+ );
+
+ Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('constructor_class' => (
reader => {
- 'immutable_transformer' => \&Class::MOP::Class::immutable_transformer
+ 'constructor_class' => \&Class::MOP::Class::constructor_class,
},
- writer => {
- '_set_immutable_transformer' => \&Class::MOP::Class::_set_immutable_transformer
+ 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::Method::Inlined
+
+ Class::MOP::Method::Inlined->meta->add_attribute(
+ Class::MOP::Attribute->new('_expected_method_class' => (
+ reader => { '_expected_method_class' => \&Class::MOP::Method::Inlined::_expected_method_class },
+ ))
+ );
+
## --------------------------------------------------------
## Class::MOP::Method::Accessor
# NOTE: we don't need to inline the the accessors this only lengthens
# the compile time of the MOP, and gives us no actual benefits.
+ # this is just nitpicking to ensure Class::MOP::Class->meta == ->meta->meta
+ Class::MOP::Class->meta->immutable_metaclass;
+ $Class::MOP::Class::immutable_metaclass_cache{"Class::MOP::Class"}{"Class::MOP::Class::Immutable::Trait"} = Class::MOP::Class::Immutable::Class::MOP::Class->meta;
+
$_->meta->make_immutable(
inline_constructor => 1,
replace_constructor => 1,
Class::MOP::Package
Class::MOP::Module
Class::MOP::Class
+ Class::MOP::Class::Immutable::Trait
+ Class::MOP::Class::Immutable::Class::MOP::Class
Class::MOP::Attribute
Class::MOP::Method
Class::MOP::Object
Class::MOP::Method::Generated
+ Class::MOP::Method::Inlined
Class::MOP::Method::Accessor
Class::MOP::Method::Constructor
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::Class::MOP::Class;
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.81';
+our $VERSION = '0.82';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
# defined in Class::MOP::Class
'superclasses' => \undef,
- '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',
+ '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' ),
+ '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, @args ) = @_;
+
+ if ( $self->is_mutable ) {
+ $self->_initialize_immutable( $self->_immutable_options(@args) );
+ $self->_rebless_as_immutable(@args);
+ return $self;
+ }
+ else {
+ return;
+ }
+ }
+
+ sub make_mutable {
my $self = shift;
- return if $self->is_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 $transformer = $self->immutable_transformer
- || $self->_make_immutable_transformer(@_);
+ sub immutable_metaclass {
+ my ( $self, %args ) = @_;
- $self->_set_immutable_transformer($transformer);
+ if ( my $class = $args{immutable_metaclass} ) {
+ return $class;
+ }
- $transformer->make_metaclass_immutable;
- }
+ my $trait = $args{immutable_trait} = $self->immutable_trait
+ || confess "no immutable trait specified for $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',
- # 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',
- },
+ my $meta_attr = $self->meta->find_attribute_by_name("immutable_trait");
- # 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;
- },
- },
- );
+ my $class_name;
+
+ if ( $meta_attr and $trait eq $meta_attr->default ) {
+
+ # if the trait is the same as the default we try and pick a predictable
+ # name for the immutable metaclass
+ $class_name = "Class::MOP::Class::Immutable::" . ref($self);
+ }
+ else {
+ $class_name
+ = join( "::", "Class::MOP::Class::Immutable::CustomTrait", $trait,
+ "ForMetaClass", ref($self) );
+ }
+
+ if ( Class::MOP::is_class_loaded($class_name) ) {
+ if ( $class_name->isa($trait) ) {
+ return $class_name;
+ }
+ else {
+ confess
+ "$class_name is already defined but does not inherit $trait";
+ }
+ }
+ else {
+ my @super = ( $trait, ref($self) );
+
+ my $meta = Class::MOP::Class->initialize($class_name);
+ $meta->superclasses(@super);
+
+ $meta->make_immutable;
- sub _default_immutable_transformer_options {
- return %Default_Immutable_Options;
+ return $class_name;
}
}
- 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;
projects / gitmo/Class-MOP.git / commitdiff