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 Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
+use Sub::Name 'subname';
+use Devel::GlobalDestruction 'in_global_destruction';
-our $VERSION = '0.79';
+our $VERSION = '0.89';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
|| confess "You must pass a package name and it cannot be blessed";
return Class::MOP::get_metaclass_by_name($package_name)
- || $class->construct_class_instance(package => $package_name, @_);
+ || $class->_construct_class_instance(package => $package_name, @_);
+}
+
+sub 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)
-# this is a special form of &construct_instance
+# this is a special form of _construct_instance
# (see below), which is used to construct class
# meta-object instances for any Class::MOP::*
# class. All other classes will use the more
# normal &construct_instance.
-sub construct_class_instance {
+sub _construct_class_instance {
my $class = shift;
my $options = @_ == 1 ? $_[0] : {@_};
my $package_name = $options->{package};
# it is safe to use meta here because
# class will always be a subclass of
# Class::MOP::Class, which defines meta
- $meta = $class->meta->construct_instance($options)
+ $meta = $class->meta->_construct_instance($options)
}
# and check the metaclass compatibility
- $meta->check_metaclass_compatibility();
+ $meta->_check_metaclass_compatibility();
Class::MOP::store_metaclass_by_name($package_name, $meta);
# 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;
}
$self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
}
+
sub 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 {
my $self = shift;
# this is always okay ...
: ref($super_meta);
($self->isa($super_meta_type))
- || confess "Class::MOP::class_of(" . $self->name . ") => ("
+ || confess "The metaclass of " . $self->name . " ("
. (ref($self)) . ")" . " is not compatible with the " .
- "Class::MOP::class_of(".$superclass_name . ") => ("
+ "metaclass of its superclass, ".$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 "Class::MOP::class_of(" . $self->name . ")->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
+ || confess "The instance metaclass for " . $self->name . " (" . ($self->instance_metaclass) . ")" .
" is not compatible with the " .
- "Class::MOP::class_of(" . $superclass_name . ")->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")";
+ "instance metaclass of its superclass, " . $superclass_name . " (" . ($super_meta->instance_metaclass) . ")";
}
}
sub DESTROY {
my $self = shift;
- return if Class::MOP::in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
+ return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
no warnings 'uninitialized';
- return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
+ my $name = $self->name;
+ return unless $name =~ /^$ANON_CLASS_PREFIX/;
# Moose does a weird thing where it replaces the metaclass for
# class when fixing metaclass incompatibility. In that case,
# we don't want to clean out the namespace now. We can detect
# that because Moose will explicitly update the singleton
# cache in Class::MOP.
- my $current_meta = Class::MOP::get_metaclass_by_name($self->name);
+ my $current_meta = Class::MOP::get_metaclass_by_name($name);
return if $current_meta ne $self;
- my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
+ my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/);
no strict 'refs';
- foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) {
- delete ${$ANON_CLASS_PREFIX . $serial_id}{$key};
- }
- delete ${'main::' . $ANON_CLASS_PREFIX}{$serial_id . '::'};
+ @{$name . '::ISA'} = ();
+ %{$name . '::'} = ();
+ delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
+
+ Class::MOP::remove_metaclass_by_name($name);
}
}
|| confess "You must pass a HASH ref of methods"
if exists $options{methods};
- $class->SUPER::create(%options);
-
my (%initialize_options) = @args;
delete @initialize_options{qw(
package
)};
my $meta = $class->initialize( $package_name => %initialize_options );
+ $meta->_instantiate_module( $options{version}, $options{authority} );
+
# FIXME totally lame
$meta->add_method('meta' => sub {
$class->initialize(ref($_[0]) || $_[0]);
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'} }
+
+sub _method_map { $_[0]->{'methods'} }
# Instance Construction & Cloning
# Class::MOP::Class singletons here, so we
# delegate this to &construct_class_instance
# which will deal with the singletons
- return $class->construct_class_instance(@_)
+ return $class->_construct_class_instance(@_)
if $class->name->isa('Class::MOP::Class');
- return $class->construct_instance(@_);
+ return $class->_construct_instance(@_);
}
sub 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 {
my $class = shift;
my $params = @_ == 1 ? $_[0] : {@_};
my $meta_instance = $class->get_meta_instance();
- my $instance = $meta_instance->create_instance();
- foreach my $attr ($class->compute_all_applicable_attributes()) {
+ # FIXME:
+ # the code below is almost certainly incorrect
+ # but this is foreign inheritance, so we might
+ # have to kludge it in the end.
+ my $instance = $params->{__INSTANCE__} || $meta_instance->create_instance();
+ foreach my $attr ($class->get_all_attributes()) {
$attr->initialize_instance_slot($meta_instance, $instance, $params);
}
# NOTE:
sub get_meta_instance {
my $self = shift;
- $self->{'_meta_instance'} ||= $self->create_meta_instance();
+ $self->{'_meta_instance'} ||= $self->_create_meta_instance();
}
sub 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 {
my $self = shift;
my $instance = $self->instance_metaclass->new(
associated_metaclass => $self,
- attributes => [ $self->compute_all_applicable_attributes() ],
+ attributes => [ $self->get_all_attributes() ],
);
$self->add_meta_instance_dependencies()
# Class::MOP::Class singletons here, they
# should not be cloned.
return $instance if $instance->isa('Class::MOP::Class');
- $class->clone_instance($instance, @_);
+ $class->_clone_instance($instance, @_);
}
sub 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 {
my ($class, $instance, %params) = @_;
(blessed($instance))
|| confess "You can only clone instances, ($instance) is not a blessed instance";
my $meta_instance = $class->get_meta_instance();
my $clone = $meta_instance->clone_instance($instance);
- foreach my $attr ($class->compute_all_applicable_attributes()) {
+ foreach my $attr ($class->get_all_attributes()) {
if ( defined( my $init_arg = $attr->init_arg ) ) {
if (exists $params{$init_arg}) {
$attr->set_value($clone, $params{$init_arg});
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
$meta_instance->rebless_instance_structure($_[1], $self);
- foreach my $attr ( $self->compute_all_applicable_attributes ) {
+ foreach my $attr ( $self->get_all_attributes ) {
if ( $attr->has_value($instance) ) {
if ( defined( my $init_arg = $attr->init_arg ) ) {
$params{$init_arg} = $attr->get_value($instance)
}
}
- foreach my $attr ($self->compute_all_applicable_attributes) {
+ foreach my $attr ($self->get_all_attributes) {
$attr->initialize_instance_slot($meta_instance, $instance, \%params);
}
# not potentially creating an issues
# we don't know about
- $self->check_metaclass_compatibility();
- $self->update_meta_instance_dependencies();
+ $self->_check_metaclass_compatibility();
+ $self->_superclasses_updated();
}
@{$self->get_package_symbol($var_spec)};
}
-sub subclasses {
+sub _superclasses_updated {
my $self = shift;
+ $self->update_meta_instance_dependencies();
+}
+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;
+ return @{ $super_class->mro::get_isarev() };
+}
- @derived_classes = sort { $a->isa($b) ? 1 : $b->isa($a) ? -1 : 0 } @derived_classes;
+sub direct_subclasses {
+ my $self = shift;
+ my $super_class = $self->name;
- return @derived_classes;
- }
+ return grep {
+ grep {
+ $_ eq $super_class
+ } Class::MOP::Class->initialize($_)->superclasses
+ } $self->subclasses;
}
-
sub linearized_isa {
return @{ mro::get_linear_isa( (shift)->name ) };
}
name => $method_name
) if $method->can('clone');
}
+
+ $method->attach_to_class($self);
+ $self->_method_map->{$method_name} = $method;
}
else {
+ # If a raw code reference is supplied, its method object is not created.
+ # The method object won't be created until required.
$body = $method;
- $method = $self->wrap_method_body( body => $body, name => $method_name );
}
- $method->attach_to_class($self);
- # This used to call get_method_map, which meant we would build all
- # the method objects for the class just because we added one
- # method. This is hackier, but quicker too.
- $self->{methods}{$method_name} = $method;
-
- my $full_method_name = ($self->name . '::' . $method_name);
+ my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
+
+ if ( !defined $current_name || $current_name eq '__ANON__' ) {
+ my $full_method_name = ($self->name . '::' . $method_name);
+ subname($full_method_name => $body);
+ }
+
$self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name },
- Class::MOP::subname($full_method_name => $body)
+ { sigil => '&', type => 'CODE', name => $method_name },
+ $body,
);
}
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_before_modifier(
- Class::MOP::subname(':before' => $method_modifier)
+ subname(':before' => $method_modifier)
);
}
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_after_modifier(
- Class::MOP::subname(':after' => $method_modifier)
+ subname(':after' => $method_modifier)
);
}
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_around_modifier(
- Class::MOP::subname(':around' => $method_modifier)
+ subname(':around' => $method_modifier)
);
}
}
sub alias_method {
- my $self = shift;
+ Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n");
+
+ shift->add_method(@_);
+}
- $self->add_method(@_);
+sub _code_is_mine{
+ my($self, $code) = @_;
+ my($code_package, $code_name) = Class::MOP::get_code_info($code);
+ return $code_package
+ && $code_package eq $self->name
+ || ($code_package eq 'constant' && $code_name eq '__ANON__');
}
sub has_method {
(defined $method_name && $method_name)
|| confess "You must define a method name";
- exists $self->{methods}{$method_name} || exists $self->get_method_map->{$method_name};
+ return defined($self->get_method($method_name));
}
sub get_method {
(defined $method_name && $method_name)
|| confess "You must define a method name";
- return $self->{methods}{$method_name} || $self->get_method_map->{$method_name};
+ my $method_map = $self->_method_map;
+ my $method_object = $method_map->{$method_name};
+ my $code = $self->get_package_symbol({
+ name => $method_name,
+ sigil => '&',
+ type => 'CODE',
+ });
+
+ if (!($method_object && $method_object->body == ($code || 0))){
+ if ($code && $self->_code_is_mine($code)) {
+ $method_object = $method_map->{$method_name} = $self->wrap_method_body(
+ body => $code,
+ name => $method_name,
+ associated_metaclass => $self,
+ );
+ }
+ else {
+ delete $method_map->{$method_name};
+ return undef;
+ }
+ }
+
+ return $method_object;
}
sub remove_method {
return values %methods;
}
-# compatibility
sub compute_all_applicable_methods {
+ Carp::cluck('The compute_all_applicable_methods method is deprecated.'
+ . " Use get_all_methods instead.\n");
+
return map {
{
name => $_->name,
} else {
$self->invalidate_meta_instances();
}
+
+ # get our count of previously inserted attributes and
+ # increment by one so this attribute knows its order
+ my $order = (scalar keys %{$self->get_attribute_map}) - 1;
+ $attribute->_set_insertion_order($order + 1);
# then onto installing the new accessors
$self->get_attribute_map->{$attribute->name} = $attribute;
# invalidate package flag here
- my $e = do { local $@; eval { $attribute->install_accessors() }; $@ };
+ my $e = do {
+ local $@;
+ local $SIG{__DIE__};
+ eval { $attribute->install_accessors() };
+ $@;
+ };
if ( $e ) {
$self->remove_attribute($attribute->name);
die $e;
$self->remove_meta_instance_dependencies;
- my @attrs = $self->compute_all_applicable_attributes();
+ my @attrs = $self->get_all_attributes();
my %seen;
my @classes = grep { not $seen{$_->name}++ } map { $_->associated_class } @attrs;
}
sub get_all_attributes {
- shift->compute_all_applicable_attributes(@_);
-}
-
-sub compute_all_applicable_attributes {
my $self = shift;
my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa;
return values %attrs;
}
+sub compute_all_applicable_attributes {
+ Carp::cluck('The compute_all_applicable_attributes method has been deprecated.'
+ . " Use get_all_attributes instead.\n");
+
+ shift->get_all_attributes(@_);
+}
+
sub find_attribute_by_name {
my ($self, $attr_name) = @_;
foreach my $class ($self->linearized_isa) {
sub is_mutable { 1 }
sub is_immutable { 0 }
-sub immutable_transformer { $_[0]->{immutable_transformer} }
-sub _set_immutable_transformer { $_[0]->{immutable_transformer} = $_[1] }
+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 _rebless_as_immutable {
+ my ( $self, @args ) = @_;
- $self->_set_immutable_transformer($transformer);
+ $self->{__immutable}{original_class} = ref $self;
- $transformer->make_metaclass_immutable;
+ bless $self => $self->_immutable_metaclass(@args);
}
-{
- 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);
+ }
+
+ return $class_name
+ if Class::MOP::is_class_loaded($class_name);
+
+ # If the metaclass is a subclass of CMOP::Class which has had
+ # metaclass roles applied (via Moose), then we want to make sure
+ # that we preserve that anonymous class (see Fey::ORM for an
+ # example of where this matters).
+ my $meta_name
+ = $self->meta->is_immutable
+ ? $self->meta->get_mutable_metaclass_name
+ : ref $self->meta;
+
+ my $meta = $meta_name->create(
+ $class_name,
+ superclasses => [ ref $self ],
);
- sub _default_immutable_transformer_options {
- return %Default_Immutable_Options;
+ Class::MOP::load_class($trait);
+ for my $meth ( Class::MOP::Class->initialize($trait)->get_all_methods ) {
+ next if $meta->has_method( $meth->name );
+
+ if ( $meta->find_method_by_name( $meth->name ) ) {
+ $meta->add_around_method_modifier( $meth->name, $meth->body );
+ }
+ else {
+ $meta->add_method( $meth->name, $meth->clone );
+ }
}
+
+ $meta->make_immutable( inline_constructor => 0 );
+
+ return $class_name;
}
-sub _make_immutable_transformer {
+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 ( $self->has_method($name) && !$args{replace_constructor} ) {
+ 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} && defined $args{destructor_class} )
+ || confess "The 'inline_destructor' option is present, but "
+ . "no destructor class was specified";
+
+ if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) {
+ my $class = $self->name;
+ warn "Not inlining a destructor for $class since it defines"
+ . " its own destructor.\n";
+ return;
+ }
+
+ my $destructor_class = $args{destructor_class};
+
+ Class::MOP::load_class($destructor_class);
+
+ return unless $destructor_class->is_needed($self);
- $self->immutable_transformer->make_metaclass_mutable;
+ my $destructor = $destructor_class->new(
+ options => \%args,
+ metaclass => $self,
+ package_name => $self->name,
+ name => 'DESTROY'
+ );
+
+ if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
+ $self->add_method( 'DESTROY' => $destructor );
+ $self->_add_inlined_method($destructor);
+ }
}
1;
# add a method to Foo ...
Foo->meta->add_method( 'bar' => sub {...} )
- # get a list of all the classes searched
- # the method dispatcher in the correct order
- Foo->meta->class_precedence_list()
+ # get a list of all the classes searched
+ # the method dispatcher in the correct order
+ Foo->meta->class_precedence_list()
- # remove a method from Foo
- Foo->meta->remove_method('bar');
+ # remove a method from Foo
+ Foo->meta->remove_method('bar');
# or use this to actually create classes ...
version => '0.01',
superclasses => ['Foo'],
attributes => [
- Class::MOP:: : Attribute->new('$bar'),
- Class::MOP:: : Attribute->new('$baz'),
+ Class::MOP::Attribute->new('$bar'),
+ Class::MOP::Attribute->new('$baz'),
],
methods => {
calculate_bar => sub {...},
This method is used to create a new object of the metaclass's
class. Any parameters you provide are used to initialize the
-instance's attributes.
+instance's attributes. A special C<__INSTANCE__> key can be passed to
+provide an already generated instance, rather than having Class::MOP
+generate it for you. This is mostly useful for using Class::MOP with
+foreign classes, which generally generate instances using their own
+constructor.
=item B<< $metaclass->instance_metaclass >>
=item B<< $metaclass->subclasses >>
-This returns a list of subclasses for this class.
+This returns a list of all subclasses for this class, even indirect
+subclasses.
+
+=item B<< $metaclass->direct_subclasses >>
+
+This returns a list of immediate subclasses for this class, which does not
+include indirect subclasses.
=back
This will return a L<Class::MOP::Attribute> for the specified
C<$attribute_name>. If the class does not have the specified
-attribute, it returns C<undef>
+attribute, it returns C<undef>.
+
+NOTE that get_attribute does not search superclasses, for that you
+need to use C<find_attribute_by_name>.
=item B<< $metaclass->has_attribute($attribute_name) >>
This will traverse the inheritance hierarchy and return a list of all
the L<Class::MOP::Attribute> objects for this class and its parents.
-This method can also be called as C<compute_all_applicable_attributes>.
-
=item B<< $metaclass->find_attribute_by_name($attribute_name) >>
This will return a L<Class::MOP::Attribute> for the specified
methods, and also allows us to optimize some methods on the metaclass
object itself.
+After immutabilization, the metaclass object will cache most
+informational methods such as C<get_method_map> and
+C<get_all_attributes>. Methods which would alter the class, such as
+C<add_attribute>, C<add_method>, and so on will throw an error on an
+immutable metaclass object.
+
The immutabilization system in L<Moose> takes much greater advantage
of the inlining features than Class::MOP itself does.
This method will create an immutable transformer and uses it to make
the class and its metaclass object immutable.
-Details of how immutabilization works are in L<Class::MOP::Immutable>
-documentation.
+This method accepts the following options:
-=item B<< $metaclass->make_mutable >>
+=over 8
-Calling this method reverse the immutabilization transformation.
+=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 * immutable_trait
+
+The name of a class which will be used as a parent class for the
+metaclass object being made immutable. This "trait" implements the
+post-immutability functionality of the metaclass (but not the
+transformation itself).
+
+This defaults to L<Class::MOP::Class::Immutable::Trait>.
+
+=item * constructor_name
+
+This is the constructor method name. This defaults to "new".
-=item B<< $metaclass->immutable_transformer >>
+=item * constructor_class
-If the class has been made immutable previously, this returns the
-L<Class::MOP::Immutable> object that was created to do the
-transformation.
+The name of the method metaclass for constructors. It will be used to
+generate the inlined constructor. This defaults to
+"Class::MOP::Method::Constructor".
-If the class was never made immutable, this method will die.
+=item * replace_constructor
+
+This is a boolean indicating whether an existing constructor should be
+replaced when inlining a constructor. This defaults to false.
+
+=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 * replace_destructor
+
+This is a boolean indicating whether an existing destructor should be
+replaced when inlining a destructor. This defaults to false.
+
+=back
+
+=item B<< $metaclass->make_mutable >>
+
+Calling this method reverse the immutabilization transformation.
=back