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 Scalar::Util 'blessed', 'reftype', 'weaken';
+use Sub::Name 'subname';
+use Devel::GlobalDestruction 'in_global_destruction';
+use Try::Tiny;
-our $VERSION = '0.78';
+our $VERSION = '0.95';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
$package_name = $options{package};
}
- (defined $package_name && $package_name && !ref($package_name))
+ ($package_name && !ref($package_name))
|| 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, @_);
}
# 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};
# get the name of the class appropriately
$class = (ref($class)
? ($class->is_immutable
- ? $class->get_mutable_metaclass_name()
+ ? $class->_get_mutable_metaclass_name()
: ref($class))
: $class);
# now create the metaclass
my $meta;
if ($class eq 'Class::MOP::Class') {
- no strict 'refs';
- $meta = $class->_new($options)
+ $meta = $class->_new($options);
}
else {
# NOTE:
# 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);
sub _new {
my $class = shift;
+
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
my $options = @_ == 1 ? $_[0] : {@_};
- bless {
+ return bless {
# inherited from Class::MOP::Package
'package' => $options->{package},
# should not actually have a value associated
# with the slot.
'namespace' => \undef,
+ 'methods' => {},
# inherited from Class::MOP::Module
'version' => \undef,
# 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',
+ '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 {
+sub _check_metaclass_compatibility {
my $self = shift;
# this is always okay ...
# get the name of the class appropriately
my $super_meta_type
= $super_meta->is_immutable
- ? $super_meta->get_mutable_metaclass_name()
+ ? $super_meta->_get_mutable_metaclass_name()
: 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 "The metaclass of " . $self->name . " ("
+ . (ref($self)) . ")" . " is not compatible with the " .
+ "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 $self->name . "->meta->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
+ || confess "The instance metaclass for " . $self->name . " (" . ($self->instance_metaclass) . ")" .
" is not compatible with the " .
- $superclass_name . "->meta->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")";
+ "instance metaclass of its superclass, " . $superclass_name . " (" . ($super_meta->instance_metaclass) . ")";
}
}
sub is_anon_class {
my $self = shift;
no warnings 'uninitialized';
- $self->name =~ /^$ANON_CLASS_PREFIX/;
+ $self->name =~ /^$ANON_CLASS_PREFIX/o;
}
sub create_anon_class {
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/o;
# 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+)/o);
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]);
# all these attribute readers will be bootstrapped
# away in the Class::MOP bootstrap section
-sub get_attribute_map { $_[0]->{'attributes'} }
+sub _attribute_map { $_[0]->{'attributes'} }
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
# 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 {
+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:
# this will only work for a HASH instance type
if ($class->is_anon_class) {
- (Scalar::Util::reftype($instance) eq 'HASH')
+ (reftype($instance) eq 'HASH')
|| confess "Currently only HASH based instances are supported with instance of anon-classes";
# NOTE:
# At some point we should make this official
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 {
+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 {
+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(ref($instance));
- }
+ my $old_metaclass = Class::MOP::class_of($instance);
- my $meta_instance = $self->get_meta_instance();
+ 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.";
- $self->name->isa($old_metaclass->name)
- || confess "You may rebless only into a subclass of (". $old_metaclass->name ."), of which (". $self->name .") isn't.";
+ $old_metaclass->rebless_instance_away($instance, $self, %params)
+ if $old_metaclass;
+
+ 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);
}
$instance;
}
+sub rebless_instance_away {
+ # this intentionally does nothing, it is just a hook
+}
+
# Inheritance
sub superclasses {
# 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 ) };
}
## Methods
-sub wrap_method_body {
- my ( $self, %args ) = @_;
-
- ('CODE' eq ref $args{body})
- || confess "Your code block must be a CODE reference";
-
- $self->method_metaclass->wrap(
- package_name => $self->name,
- %args,
- );
-}
-
-sub add_method {
- my ($self, $method_name, $method) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- my $body;
- if (blessed($method)) {
- $body = $method->body;
- if ($method->package_name ne $self->name) {
- $method = $method->clone(
- package_name => $self->name,
- name => $method_name
- ) if $method->can('clone');
- }
- }
- else {
- $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);
- $self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name },
- Class::MOP::subname($full_method_name => $body)
- );
-}
-
{
my $fetch_and_prepare_method = sub {
my ($self, $method_name) = @_;
# and now make sure to wrap it
# even if it is already wrapped
# because we need a new sub ref
- $method = $wrapped_metaclass->wrap($method);
+ $method = $wrapped_metaclass->wrap($method,
+ package_name => $self->name,
+ name => $method_name,
+ );
}
else {
# now make sure we wrap it properly
- $method = $wrapped_metaclass->wrap($method)
- unless $method->isa($wrapped_metaclass);
+ $method = $wrapped_metaclass->wrap($method,
+ package_name => $self->name,
+ name => $method_name,
+ ) unless $method->isa($wrapped_metaclass);
}
$self->add_method($method_name => $method);
return $method;
sub add_before_method_modifier {
my ($self, $method_name, $method_modifier) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| 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)
);
}
sub add_after_method_modifier {
my ($self, $method_name, $method_modifier) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| 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)
);
}
sub add_around_method_modifier {
my ($self, $method_name, $method_modifier) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| 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)
);
}
# to, and so don't need the fully qualified name.
}
-sub alias_method {
- my $self = shift;
-
- $self->add_method(@_);
-}
-
-sub has_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- exists $self->{methods}{$method_name} || exists $self->get_method_map->{$method_name};
-}
-
-sub get_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- return $self->{methods}{$method_name} || $self->get_method_map->{$method_name};
-}
-
-sub remove_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- my $removed_method = delete $self->get_method_map->{$method_name};
-
- $self->remove_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name }
- );
-
- $removed_method->detach_from_class if $removed_method;
-
- $self->update_package_cache_flag; # still valid, since we just removed the method from the map
-
- return $removed_method;
-}
-
-sub get_method_list {
- my $self = shift;
- keys %{$self->get_method_map};
-}
-
sub find_method_by_name {
my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must define a method name to find";
foreach my $class ($self->linearized_isa) {
- # fetch the meta-class ...
- my $meta = $self->initialize($class);
- return $meta->get_method($method_name)
- if $meta->has_method($method_name);
+ my $method = $self->initialize($class)->get_method($method_name);
+ return $method if defined $method;
}
return;
}
sub get_all_methods {
my $self = shift;
- my %methods = map { %{ $self->initialize($_)->get_method_map } } reverse $self->linearized_isa;
- return values %methods;
-}
-# compatibility
-sub compute_all_applicable_methods {
- return map {
- {
- name => $_->name,
- class => $_->package_name,
- code => $_, # sigh, overloading
- },
- } shift->get_all_methods(@_);
+ my %methods;
+ for my $class ( reverse $self->linearized_isa ) {
+ my $meta = $self->initialize($class);
+
+ $methods{$_} = $meta->get_method($_)
+ for $meta->get_method_list;
+ }
+
+ return values %methods;
}
sub get_all_method_names {
my $self = shift;
my %uniq;
- grep { $uniq{$_}++ == 0 } map { $_->name } $self->get_all_methods;
+ return grep { !$uniq{$_}++ } map { $self->initialize($_)->get_method_list } $self->linearized_isa;
}
sub find_all_methods_by_name {
my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must define a method name to find";
my @methods;
foreach my $class ($self->linearized_isa) {
sub find_next_method_by_name {
my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must define a method name to find";
my @cpl = $self->linearized_isa;
shift @cpl; # discard ourselves
foreach my $class (@cpl) {
- # fetch the meta-class ...
- my $meta = $self->initialize($class);
- return $meta->get_method($method_name)
- if $meta->has_method($method_name);
+ my $method = $self->initialize($class)->get_method($method_name);
+ return $method if defined $method;
}
return;
}
# about the class which it is attached to
$attribute->attach_to_class($self);
+ my $attr_name = $attribute->name;
+
# then we remove attributes of a conflicting
# name here so that we can properly detach
# the old attr object, and remove any
# accessors it would have generated
- if ( $self->has_attribute($attribute->name) ) {
- $self->remove_attribute($attribute->name);
+ if ( $self->has_attribute($attr_name) ) {
+ $self->remove_attribute($attr_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->_attribute_map});
+ $attribute->_set_insertion_order($order);
# then onto installing the new accessors
- $self->get_attribute_map->{$attribute->name} = $attribute;
+ $self->_attribute_map->{$attr_name} = $attribute;
# invalidate package flag here
- my $e = do { local $@; eval { $attribute->install_accessors() }; $@ };
- if ( $e ) {
- $self->remove_attribute($attribute->name);
- die $e;
+ try {
+ local $SIG{__DIE__};
+ $attribute->install_accessors();
}
+ catch {
+ $self->remove_attribute($attr_name);
+ die $_;
+ };
return $attribute;
}
$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 has_attribute {
my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
+ (defined $attribute_name)
|| confess "You must define an attribute name";
- exists $self->get_attribute_map->{$attribute_name};
+ exists $self->_attribute_map->{$attribute_name};
}
sub get_attribute {
my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
+ (defined $attribute_name)
|| confess "You must define an attribute name";
- return $self->get_attribute_map->{$attribute_name}
+ return $self->_attribute_map->{$attribute_name}
# NOTE:
# this will return undef anyway, so no need ...
# if $self->has_attribute($attribute_name);
sub remove_attribute {
my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
+ (defined $attribute_name)
|| confess "You must define an attribute name";
- my $removed_attribute = $self->get_attribute_map->{$attribute_name};
+ my $removed_attribute = $self->_attribute_map->{$attribute_name};
return unless defined $removed_attribute;
- delete $self->get_attribute_map->{$attribute_name};
+ delete $self->_attribute_map->{$attribute_name};
$self->invalidate_meta_instances();
$removed_attribute->remove_accessors();
$removed_attribute->detach_from_class();
sub get_attribute_list {
my $self = shift;
- keys %{$self->get_attribute_map};
+ keys %{$self->_attribute_map};
}
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;
+ my %attrs = map { %{ $self->initialize($_)->_attribute_map } } reverse $self->linearized_isa;
return values %attrs;
}
return if $self->get_attribute_list;
# or any non-declared methods
- if ( my @methods = values %{ $self->get_method_map } ) {
- my $metaclass = $self->method_metaclass;
- foreach my $method ( @methods ) {
- return if $method->isa("Class::MOP::Method::Generated");
- # FIXME do we need to enforce this too? return unless $method->isa($metaclass);
- }
+ for my $method ( map { $self->get_method($_) } $self->get_method_list ) {
+ return if $method->isa("Class::MOP::Method::Generated");
+ # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass );
}
return 1;
sub is_mutable { 1 }
sub is_immutable { 0 }
-# NOTE:
-# Why I changed this (groditi)
-# - One Metaclass may have many Classes through many Metaclass instances
-# - One Metaclass should only have one Immutable Transformer instance
-# - Each Class may have different Immutabilizing options
-# - Therefore each Metaclass instance may have different Immutabilizing options
-# - We need to store one Immutable Transformer instance per Metaclass
-# - We need to store one set of Immutable Transformer options per Class
-# - Upon make_mutable we may delete the Immutabilizing options
-# - We could clean the immutable Transformer instance when there is no more
-# immutable Classes of that type, but we can also keep it in case
-# another class with this same Metaclass becomes immutable. It is a case
-# of trading of storing an instance to avoid unnecessary instantiations of
-# Immutable Transformers. You may view this as a memory leak, however
-# Because we have few Metaclasses, in practice it seems acceptable
-# - To allow Immutable Transformers instances to be cleaned up we could weaken
-# the reference stored in $IMMUTABLE_TRANSFORMERS{$class} and ||= should DWIM
+sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
+
+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 ) = @_;
- my %IMMUTABLE_TRANSFORMERS;
- my %IMMUTABLE_OPTIONS;
+ if ( $self->is_mutable ) {
+ $self->_initialize_immutable( $self->_immutable_options(@args) );
+ $self->_rebless_as_immutable(@args);
+ return $self;
+ }
+ else {
+ return;
+ }
+}
- sub get_immutable_options {
- my $self = shift;
- return if $self->is_mutable;
- confess "unable to find immutabilizing options"
- unless exists $IMMUTABLE_OPTIONS{$self->name};
- my %options = %{$IMMUTABLE_OPTIONS{$self->name}};
- delete $options{IMMUTABLE_TRANSFORMER};
- return \%options;
+sub make_mutable {
+ my $self = shift;
+
+ 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;
}
+}
- sub get_immutable_transformer {
- my $self = shift;
- if( $self->is_mutable ){
- return $IMMUTABLE_TRANSFORMERS{$self->name} ||= $self->create_immutable_transformer;
- }
- confess "unable to find transformer for immutable class"
- unless exists $IMMUTABLE_OPTIONS{$self->name};
- return $IMMUTABLE_OPTIONS{$self->name}->{IMMUTABLE_TRANSFORMER};
+sub _rebless_as_immutable {
+ my ( $self, @args ) = @_;
+
+ $self->{__immutable}{original_class} = ref $self;
+
+ bless $self => $self->_immutable_metaclass(@args);
+}
+
+sub _immutable_metaclass {
+ my ( $self, %args ) = @_;
+
+ if ( my $class = $args{immutable_metaclass} ) {
+ return $class;
}
- sub make_immutable {
- my $self = shift;
- my %options = @_;
+ my $trait = $args{immutable_trait} = $self->immutable_trait
+ || confess "no immutable trait specified for $self";
- my $transformer = $self->get_immutable_transformer;
- $transformer->make_metaclass_immutable($self, \%options);
- $IMMUTABLE_OPTIONS{$self->name} =
- { %options, IMMUTABLE_TRANSFORMER => $transformer };
+ my $meta = $self->meta;
+ my $meta_attr = $meta->find_attribute_by_name("immutable_trait");
- if( exists $options{debug} && $options{debug} ){
- print STDERR "# of Metaclass options: ", keys %IMMUTABLE_OPTIONS;
- print STDERR "# of Immutable transformers: ", keys %IMMUTABLE_TRANSFORMERS;
- }
+ my $class_name;
- 1;
+ 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);
}
- sub make_mutable{
- my $self = shift;
- return if $self->is_mutable;
- my $options = delete $IMMUTABLE_OPTIONS{$self->name};
- confess "unable to find immutabilizing options" unless ref $options;
- my $transformer = delete $options->{IMMUTABLE_TRANSFORMER};
- $transformer->make_metaclass_mutable($self, $options);
- 1;
+ 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
+ = $meta->is_immutable
+ ? $meta->_get_mutable_metaclass_name
+ : ref $meta;
+
+ my $immutable_meta = $meta_name->create(
+ $class_name,
+ superclasses => [ ref $self ],
+ );
+
+ Class::MOP::load_class($trait);
+ for my $meth ( Class::MOP::Class->initialize($trait)->get_all_methods ) {
+ my $meth_name = $meth->name;
+
+ if ( $immutable_meta->find_method_by_name( $meth_name ) ) {
+ $immutable_meta->add_around_method_modifier( $meth_name, $meth->body );
+ }
+ else {
+ $immutable_meta->add_method( $meth_name, $meth->clone );
+ }
}
+
+ $immutable_meta->make_immutable(
+ inline_constructor => 0,
+ inline_accessors => 0,
+ );
+
+ return $class_name;
}
-sub create_immutable_transformer {
+sub _remove_inlined_code {
my $self = shift;
- my $class = Class::MOP::Immutable->new($self, {
- 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',
- linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
- get_all_methods => 'ARRAY',
- get_all_method_names => 'ARRAY',
- #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future
- compute_all_applicable_attributes => 'ARRAY',
- get_meta_instance => 'SCALAR',
- get_method_map => 'SCALAR',
- },
- # 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;
- },
- },
- });
- return $class;
+
+ $self->remove_method( $_->name ) for $self->_inlined_methods;
+
+ delete $self->{__immutable}{inlined_methods};
+}
+
+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;
+
+ 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);
+
+ 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 {...},
The Class Protocol is the largest and most complex part of the
Class::MOP meta-object protocol. It controls the introspection and
manipulation of Perl 5 classes, and it can create them as well. The
-best way to understand what this module can do, is to read the
+best way to understand what this module can do is to read the
documentation for each of its methods.
=head1 INHERITANCE
=head2 Class construction
These methods all create new C<Class::MOP::Class> objects. These
-objects can represent existing classes, or they can be used to create
+objects can represent existing classes or they can be used to create
new classes from scratch.
The metaclass object for a given class is a singleton. If you attempt
=item B<< Class::MOP::Class->create($package_name, %options) >>
This method creates a new C<Class::MOP::Class> object with the given
-package name. It accepts a number of options.
+package name. It accepts a number of options:
=over 8
=item * methods
An optional hash reference of methods for the class. The keys of the
-hash reference are method names, and values are subroutine references.
+hash reference are method names and values are subroutine references.
=item * attributes
-An optional array reference of attributes.
-
-An attribute can be passed as an existing L<Class::MOP::Attribute>
-object, I<or> or as a hash reference of options which will be passed
-to the attribute metaclass's constructor.
+An optional array reference of L<Class::MOP::Attribute> objects.
=back
metaclass object, which prevents the metaclass from going out of scope
while any instances exist.
-This only works if the instance if based on a hash reference, however.
+This only works if the instance is based on a hash reference, however.
=item B<< Class::MOP::Class->initialize($package_name, %options) >>
attributes. Any existing attributes that are already set will be
overwritten.
+Before reblessing the instance, this method will call
+C<rebless_instance_away> on the instance's current metaclass. This method
+will be passed the instance, the new metaclass, and any parameters
+specified to C<rebless_instance>. By default, C<rebless_instance_away>
+does nothing; it is merely a hook.
+
=item B<< $metaclass->new_object(%params) >>
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 generate instances using their own constructors.
=item B<< $metaclass->instance_metaclass >>
-Returns the class name of the instance metaclass, see
+Returns the class name of the instance metaclass. See
L<Class::MOP::Instance> for more information on the instance
-metaclasses.
+metaclass.
=item B<< $metaclass->get_meta_instance >>
=item B<< $metaclass->subclasses >>
-This returns a list of subclasses for this class.
-
-=back
-
-=head2 Method introspection and creation
+This returns a list of all subclasses for this class, even indirect
+subclasses.
-These methods allow you to introspect a class's methods, as well as
-add, remove, or change methods.
+=item B<< $metaclass->direct_subclasses >>
-Determining what is truly a method in a Perl 5 class requires some
-heuristics (aka guessing).
+This returns a list of immediate subclasses for this class, which does not
+include indirect subclasses.
-Methods defined outside the package with a fully qualified name (C<sub
-Package::name { ... }>) will be included. Similarly, methods named
-with a fully qualified name using L<Sub::Name> are also included.
+=back
-However, we attempt to ignore imported functions.
+=head2 Method introspection
-Ultimately, we are using heuristics to determine what truly is a
-method in a class, and these heuristics may get the wrong answer in
-some edge cases. However, for most "normal" cases the heuristics work
-correctly.
+See L<Class::MOP::Package/Method introspection and creation> for
+methods that operate only on the current class. Class::MOP::Class adds
+introspection capabilities that take inheritance into account.
=over 4
-=item B<< $metaclass->get_method($method_name) >>
-
-This will return a L<Class::MOP::Method> for the specified
-C<$method_name>. If the class does not have the specified method, it
-returns C<undef>
-
-=item B<< $metaclass->has_method($method_name) >>
-
-Returns a boolean indicating whether or not the class defines the
-named method. It does not include methods inherited from parent
-classes.
-
-=item B<< $metaclass->get_method_map >>
-
-Returns a hash reference representing the methods defined in this
-class. The keys are method names and the values are
-L<Class::MOP::Method> objects.
-
-=item B<< $metaclass->get_method_list >>
-
-This will return a list of method I<names> for all methods defined in
-this class.
-
=item B<< $metaclass->get_all_methods >>
This will traverse the inheritance hierarchy and return a list of all
given name. It is effectively the method that C<SUPER::$method_name>
would dispatch to.
-=item B<< $metaclass->add_method($method_name, $method) >>
-
-This method takes a method name and a subroutine reference, and adds
-the method to the class.
-
-The subroutine reference can be a L<Class::MOP::Method>, and you are
-strongly encouraged to pass a meta method object instead of a code
-reference. If you do so, that object gets stored as part of the
-class's method map directly. If not, the meta information will have to
-be recreated later, and may be incorrect.
-
-If you provide a method object, this method will clone that object if
-the object's package name does not match the class name. This lets us
-track the original source of any methods added from other classes
-(notably Moose roles).
-
-=item B<< $metaclass->remove_method($method_name) >>
-
-Remove the named method from the class. This method returns the
-L<Class::MOP::Method> object for the method.
-
=back
=head2 Attribute introspection and creation
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) >>
named attribute. It does not include attributes inherited from parent
classes.
-=item B<< $metaclass->get_attribute_map >>
-
-Returns a hash reference representing the attributes defined in this
-class. The keys are attribute names and the values are
-L<Class::MOP::Attribute> objects.
-
=item B<< $metaclass->get_attribute_list >>
This will return a list of attributes I<names> for all attributes
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
C<$attribute_name>. If the class does not have the specified
-attribute, it returns C<undef>
+attribute, it returns C<undef>.
Unlike C<get_attribute>, this attribute I<will> look for the named
attribute in superclasses.
=item B<< $metaclass->add_attribute(...) >>
This method accepts either an existing L<Class::MOP::Attribute>
-object, or parameters suitable for passing to that class's C<new>
+object or parameters suitable for passing to that class's C<new>
method.
The attribute provided will be added to the class.
=item B<< $metaclass->attribute_metaclass >>
Returns the class name of the attribute metaclass for this class. By
-default, this is L<Class::MOP::Attribute>. for more information on
+default, this is L<Class::MOP::Attribute>.
=back
methods, and also allows us to optimize some methods on the metaclass
object itself.
+After immutabilization, the metaclass object will cache most informational
+methods that returns information about methods or attributes. Methods which
+would alter the class, such as C<add_attribute> and C<add_method>, 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.
=item B<< $metaclass->make_immutable(%options) >>
-This method will create an immutable transformer and uses it to make
+This method will create an immutable transformer and use 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 B<< $metaclass->get_immutable_transformer >>
+=item * constructor_name
-If the class has been made immutable previously, this returns the
-L<Class::MOP::Immutable> object that was created to do the
-transformation.
+This is the constructor method name. This defaults to "new".
-If the class was never made immutable, this method will die.
+=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 * 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->immutable_options >>
+
+Returns a hash of the options used when making the class immutable, including
+both defaults and anything supplied by the user in the call to C<<
+$metaclass->make_immutable >>. This is useful if you need to temporarily make
+a class mutable and then restore immutability as it was before.
+
+=item B<< $metaclass->make_mutable >>
+
+Calling this method reverse the immutabilization transformation.
=back
Method modifiers are hooks which allow a method to be wrapped with
I<before>, I<after> and I<around> method modifiers. Every time a
-method is called, it's modifiers are also called.
+method is called, its modifiers are also called.
A class can modify its own methods, as well as methods defined in
parent classes.
Of course there is a performance cost associated with method
modifiers, but we have made every effort to make that cost directly
-proportional to the number of modifier features you utilize.
+proportional to the number of modifier features you use.
-The wrapping method does it's best to B<only> do as much work as it
+The wrapping method does its best to B<only> do as much work as it
absolutely needs to. In order to do this we have moved some of the
performance costs to set-up time, where they are easier to amortize.