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.78_02';
+our $VERSION = '0.81';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
}
sub construct_class_instance {
- warn 'The construct_class_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n";
- shift->_construct_class_instance;
+ Carp::cluck('The construct_class_instance method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n");
+ shift->_construct_class_instance(@_);
}
# NOTE: (meta-circularity)
'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 check_metaclass_compatibility {
- warn 'The check_metaclass_compatibility method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n";
- shift->_check_metaclass_compatibility;
+ Carp::cluck('The check_metaclass_compatibility method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n");
+ shift->_check_metaclass_compatibility(@_);
}
sub _check_metaclass_compatibility {
: ref($super_meta);
($self->isa($super_meta_type))
- || confess $self->name . "->meta => (" . (ref($self)) . ")" .
- " is not compatible with the " .
- $superclass_name . "->meta => (" . ($super_meta_type) . ")";
+ || confess "Class::MOP::class_of(" . $self->name . ") => ("
+ . (ref($self)) . ")" . " is not compatible with the " .
+ "Class::MOP::class_of(".$superclass_name . ") => ("
+ . ($super_meta_type) . ")";
# NOTE:
# we also need to check that instance metaclasses
# are compatibile in the same the class.
($self->instance_metaclass->isa($super_meta->instance_metaclass))
- || confess $self->name . "->meta->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
+ || confess "Class::MOP::class_of(" . $self->name . ")->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
" is not compatible with the " .
- $superclass_name . "->meta->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")";
+ "Class::MOP::class_of(" . $superclass_name . ")->instance_metaclass => (" . ($super_meta->instance_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
}
sub construct_instance {
- warn 'The construct_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n";
- shift->_construct_instance;
+ Carp::cluck('The construct_instance method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n");
+ shift->_construct_instance(@_);
}
sub _construct_instance {
}
sub create_meta_instance {
- warn 'The create_meta_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n";
- shift->_create_meta_instance;
+ Carp::cluck('The create_meta_instance method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n");
+ shift->_create_meta_instance(@_);
}
sub _create_meta_instance {
}
sub clone_instance {
- warn 'The clone_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n";
- shift->_clone_instance;
+ Carp::cluck('The clone_instance method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n");
+ shift->_clone_instance(@_);
}
sub _clone_instance {
sub rebless_instance {
my ($self, $instance, %params) = @_;
- my $old_metaclass;
- if ($instance->can('meta')) {
- ($instance->meta->isa('Class::MOP::Class'))
- || confess 'Cannot rebless instance if ->meta is not an instance of Class::MOP::Class';
- $old_metaclass = $instance->meta;
- }
- else {
- $old_metaclass = $self->initialize(blessed($instance));
- }
+ my $old_metaclass = Class::MOP::class_of($instance);
- $old_metaclass->rebless_instance_away($instance, $self, %params);
+ my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
+ $self->name->isa($old_class)
+ || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
- my $meta_instance = $self->get_meta_instance();
+ $old_metaclass->rebless_instance_away($instance, $self, %params)
+ if $old_metaclass;
- $self->name->isa($old_metaclass->name)
- || confess "You may rebless only into a subclass of (". $old_metaclass->name ."), of which (". $self->name .") isn't.";
+ my $meta_instance = $self->get_meta_instance();
# rebless!
# we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
sub subclasses {
my $self = shift;
-
my $super_class = $self->name;
- if ( Class::MOP::HAVE_ISAREV() ) {
- return @{ $super_class->mro::get_isarev() };
- } else {
- my @derived_classes;
-
- my $find_derived_classes;
- $find_derived_classes = sub {
- my ($outer_class) = @_;
-
- my $symbol_table_hashref = do { no strict 'refs'; \%{"${outer_class}::"} };
-
- SYMBOL:
- for my $symbol ( keys %$symbol_table_hashref ) {
- next SYMBOL if $symbol !~ /\A (\w+):: \z/x;
- my $inner_class = $1;
-
- next SYMBOL if $inner_class eq 'SUPER'; # skip '*::SUPER'
-
- my $class =
- $outer_class
- ? "${outer_class}::$inner_class"
- : $inner_class;
-
- if ( $class->isa($super_class) and $class ne $super_class ) {
- push @derived_classes, $class;
- }
-
- next SYMBOL if $class eq 'main'; # skip 'main::*'
-
- $find_derived_classes->($class);
- }
- };
-
- my $root_class = q{};
- $find_derived_classes->($root_class);
-
- undef $find_derived_classes;
-
- @derived_classes = sort { $a->isa($b) ? 1 : $b->isa($a) ? -1 : 0 } @derived_classes;
-
- return @derived_classes;
- }
+ return @{ $super_class->mro::get_isarev() };
}
}
sub alias_method {
- warn "The alias_method method is deprecated. Use add_method instead.\n";
+ Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n");
- shift->add_method;
+ shift->add_method(@_);
}
sub has_method {
}
sub compute_all_applicable_methods {
- warn 'The compute_all_applicable_methods method is deprecated.'
- . " Use get_all_methods instead.\n";
+ Carp::cluck('The compute_all_applicable_methods method is deprecated.'
+ . " Use get_all_methods instead.\n");
return map {
{
}
sub compute_all_applicable_attributes {
- warn 'The construct_class_instance method has been deprecated.'
- . " Use get_all_attributes instead.\n";
+ Carp::cluck('The compute_all_applicable_attributes method has been deprecated.'
+ . " Use get_all_attributes instead.\n");
- shift->get_all_attributes;
+ shift->get_all_attributes(@_);
}
sub find_attribute_by_name {
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',
- compute_all_applicable_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;
+ }
+
+ my $trait = $args{immutable_trait} = $self->immutable_trait
+ || confess "no immutable trait specified for $self";
+
+ my $meta_attr = $self->meta->find_attribute_by_name("immutable_trait");
+
+ 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 / blobdiff