X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=b3b6b97b0bfcf86d2b4d1c2e04d7fbd7dca56c1f;hb=7d1a576bad6260090ba0d40950f861227ead48a8;hp=91a65175ad72854a63ded2f4f1012a948cc364ad;hpb=583794707de9c1902b8b41f020cde3ddcc9fa80b;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 91a6517..b3b6b97 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -4,18 +4,26 @@ package Class::MOP::Class; 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::MiniTrait; 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; +use List::MoreUtils 'all'; -our $VERSION = '0.78'; +our $VERSION = '1.08'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; -use base 'Class::MOP::Module'; +use base 'Class::MOP::Module', + 'Class::MOP::Mixin::HasAttributes', + 'Class::MOP::Mixin::HasMethods'; # Creation @@ -31,21 +39,15 @@ sub initialize { $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, @_); } -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"; - goto &_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 @@ -66,28 +68,22 @@ sub _construct_class_instance { return $meta; } - # NOTE: - # we need to deal with the possibility - # of class immutability here, and then - # get the name of the class appropriately - $class = (ref($class) - ? ($class->is_immutable - ? $class->get_mutable_metaclass_name() - : ref($class)) - : $class); + $class + = ref $class + ? $class->_real_ref_name + : $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 @@ -103,11 +99,25 @@ sub _construct_class_instance { $meta; } +sub _real_ref_name { + my $self = shift; + + # NOTE: we need to deal with the possibility of class immutability here, + # and then get the name of the class appropriately + return $self->is_immutable + ? $self->_get_mutable_metaclass_name() + : ref $self; +} + 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}, @@ -120,6 +130,7 @@ sub _new { # should not actually have a value associated # with the slot. 'namespace' => \undef, + 'methods' => {}, # inherited from Class::MOP::Module 'version' => \undef, @@ -128,16 +139,26 @@ sub _new { # 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; } @@ -153,46 +174,223 @@ sub update_package_cache_flag { $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); } +## Metaclass compatibility +{ + my %base_metaclass = ( + attribute_metaclass => 'Class::MOP::Attribute', + method_metaclass => 'Class::MOP::Method', + wrapped_method_metaclass => 'Class::MOP::Method::Wrapped', + instance_metaclass => 'Class::MOP::Instance', + constructor_class => 'Class::MOP::Method::Constructor', + destructor_class => 'Class::MOP::Method::Destructor', + ); -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"; - goto &_check_metaclass_compatibility; + sub _base_metaclasses { %base_metaclass } } sub _check_metaclass_compatibility { my $self = shift; + my @superclasses = $self->superclasses + or return; + + $self->_fix_metaclass_incompatibility(@superclasses); + + my %base_metaclass = $self->_base_metaclasses; + # this is always okay ... - return if ref($self) eq 'Class::MOP::Class' && - $self->instance_metaclass eq 'Class::MOP::Instance'; + return + if ref($self) eq 'Class::MOP::Class' + && all { + my $meta = $self->$_; + !defined($meta) || $meta eq $base_metaclass{$_}; + } + keys %base_metaclass; - my @class_list = $self->linearized_isa; - shift @class_list; # shift off $self->name + for my $superclass (@superclasses) { + $self->_check_class_metaclass_compatibility($superclass); + } - foreach my $superclass_name (@class_list) { - my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || next; + for my $metaclass_type ( keys %base_metaclass ) { + next unless defined $self->$metaclass_type; + for my $superclass (@superclasses) { + $self->_check_single_metaclass_compatibility( $metaclass_type, + $superclass ); + } + } +} - # NOTE: - # we need to deal with the possibility - # of class immutability here, and then - # get the name of the class appropriately - my $super_meta_type - = $super_meta->is_immutable - ? $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) . ")"; - # 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) . ")" . - " is not compatible with the " . - $superclass_name . "->meta->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")"; +sub _class_metaclass_is_compatible { + my $self = shift; + my ( $superclass_name ) = @_; + + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) + || return 1; + + my $super_meta_type = $super_meta->_real_ref_name; + + return $self->isa($super_meta_type); +} + +sub _check_class_metaclass_compatibility { + my $self = shift; + my ( $superclass_name ) = @_; + + if (!$self->_class_metaclass_is_compatible($superclass_name)) { + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name); + + my $super_meta_type = $super_meta->_real_ref_name; + + confess "The metaclass of " . $self->name . " (" + . (ref($self)) . ")" . " is not compatible with " + . "the metaclass of its superclass, " + . $superclass_name . " (" . ($super_meta_type) . ")"; + } +} + +sub _single_metaclass_is_compatible { + my $self = shift; + my ( $metaclass_type, $superclass_name ) = @_; + + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) + || return 1; + + # for instance, Moose::Meta::Class has a error_class attribute, but + # Class::MOP::Class doesn't - this shouldn't be an error + return 1 unless $super_meta->can($metaclass_type); + # for instance, Moose::Meta::Class has a destructor_class, but + # Class::MOP::Class doesn't - this shouldn't be an error + return 1 unless defined $super_meta->$metaclass_type; + # if metaclass is defined in superclass but not here, it's not compatible + # this is a really odd case + return 0 unless defined $self->$metaclass_type; + + return $self->$metaclass_type->isa($super_meta->$metaclass_type); +} + +sub _check_single_metaclass_compatibility { + my $self = shift; + my ( $metaclass_type, $superclass_name ) = @_; + + if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) { + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name); + my $metaclass_type_name = $metaclass_type; + $metaclass_type_name =~ s/_(?:meta)?class$//; + $metaclass_type_name =~ s/_/ /g; + confess "The $metaclass_type_name metaclass for " + . $self->name . " (" . ($self->$metaclass_type) + . ")" . " is not compatible with the " + . "$metaclass_type_name metaclass of its " + . "superclass, $superclass_name (" + . ($super_meta->$metaclass_type) . ")"; + } +} + +sub _can_fix_class_metaclass_incompatibility_by_subclassing { + my $self = shift; + my ($super_meta) = @_; + + my $super_meta_type = $super_meta->_real_ref_name; + + return $super_meta_type ne blessed($self) + && $super_meta->isa(blessed($self)); +} + +sub _can_fix_single_metaclass_incompatibility_by_subclassing { + my $self = shift; + my ($metaclass_type, $super_meta) = @_; + + my $specific_meta = $self->$metaclass_type; + return unless $super_meta->can($metaclass_type); + my $super_specific_meta = $super_meta->$metaclass_type; + + # for instance, Moose::Meta::Class has a destructor_class, but + # Class::MOP::Class doesn't - this shouldn't be an error + return unless defined $super_specific_meta; + + # if metaclass is defined in superclass but not here, it's fixable + # this is a really odd case + return 1 unless defined $specific_meta; + + return $specific_meta ne $super_specific_meta + && $super_specific_meta->isa($specific_meta); +} + +sub _can_fix_metaclass_incompatibility_by_subclassing { + my $self = shift; + my ($super_meta) = @_; + + return 1 if $self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta); + + my %base_metaclass = $self->_base_metaclasses; + for my $metaclass_type (keys %base_metaclass) { + return 1 if $self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta); + } + + return; +} + +sub _can_fix_metaclass_incompatibility { + my $self = shift; + return $self->_can_fix_metaclass_incompatibility_by_subclassing(@_); +} + +sub _fix_metaclass_incompatibility { + my $self = shift; + my @supers = map { Class::MOP::Class->initialize($_) } @_; + + my $necessary = 0; + for my $super (@supers) { + $necessary = 1 + if $self->_can_fix_metaclass_incompatibility($super); + } + return unless $necessary; + + for my $super (@supers) { + if (!$self->_class_metaclass_is_compatible($super->name)) { + $self->_fix_class_metaclass_incompatibility($super); + } + } + + my %base_metaclass = $self->_base_metaclasses; + for my $metaclass_type (keys %base_metaclass) { + for my $super (@supers) { + if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) { + $self->_fix_single_metaclass_incompatibility( + $metaclass_type, $super + ); + } + } + } +} + +sub _fix_class_metaclass_incompatibility { + my $self = shift; + my ( $super_meta ) = @_; + + if ($self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta)) { + ($self->is_pristine) + || confess "Can't fix metaclass incompatibility for " + . $self->name + . " because it is not pristine."; + + my $super_meta_name = $super_meta->_real_ref_name; + + $super_meta_name->meta->rebless_instance($self); + } +} + +sub _fix_single_metaclass_incompatibility { + my $self = shift; + my ( $metaclass_type, $super_meta ) = @_; + + if ($self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta)) { + ($self->is_pristine) + || confess "Can't fix metaclass incompatibility for " + . $self->name + . " because it is not pristine."; + + $self->{$metaclass_type} = $super_meta->$metaclass_type; } } @@ -215,7 +413,7 @@ sub _check_metaclass_compatibility { 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 { @@ -233,24 +431,27 @@ sub _check_metaclass_compatibility { 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); } } @@ -277,23 +478,32 @@ sub create { || 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 superclasses attributes methods + no_meta version authority )}; my $meta = $class->initialize( $package_name => %initialize_options ); + $meta->_instantiate_module( $options{version}, $options{authority} ); + # FIXME totally lame $meta->add_method('meta' => sub { + if (Class::MOP::DEBUG_NO_META()) { + my ($self) = @_; + if (my $meta = try { $self->SUPER::meta }) { + return $meta if $meta->isa('Class::MOP::Class'); + } + confess "'meta' method called by MOP internals" + if caller =~ /Class::MOP|metaclass/; + } $class->initialize(ref($_[0]) || $_[0]); - }); + }) unless $options{no_meta}; $meta->superclasses(@{$options{superclasses}}) if exists $options{superclasses}; @@ -321,11 +531,11 @@ sub create { # all these attribute readers will be bootstrapped # away in the Class::MOP bootstrap section -sub get_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 @@ -339,21 +549,39 @@ sub new_object { # which will deal with the singletons 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; + if (my $instance_class = blessed($params->{__INSTANCE__})) { + ($instance_class eq $class->name) + || confess "Objects passed as the __INSTANCE__ parameter must " + . "already be blessed into the correct class, but " + . "$params->{__INSTANCE__} is not a " . $class->name; + $instance = $params->{__INSTANCE__}; + } + elsif (exists $params->{__INSTANCE__}) { + confess "The __INSTANCE__ parameter must be a blessed reference, not " + . $params->{__INSTANCE__}; + } + else { + $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 @@ -371,18 +599,12 @@ sub get_meta_instance { $self->{'_meta_instance'} ||= $self->_create_meta_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"; - goto &_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() @@ -391,6 +613,13 @@ sub _create_meta_instance { return $instance; } +sub inline_create_instance { + my $self = shift; + my ($class) = @_; + + return $self->get_meta_instance->inline_create_instance($class); +} + sub clone_object { my $class = shift; my $instance = shift; @@ -405,19 +634,13 @@ sub clone_object { $class->_clone_instance($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"; - goto &_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}); @@ -430,26 +653,22 @@ 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(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."; + + $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) @@ -461,21 +680,112 @@ sub rebless_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_back { + my ( $self, $instance ) = @_; + + my $old_metaclass = Class::MOP::class_of($instance); + + my $old_class + = $old_metaclass ? $old_metaclass->name : blessed($instance); + $old_class->isa( $self->name ) + || confess + "You may rebless only into a superclass of ($old_class), of which (" + . $self->name + . ") isn't."; + + $old_metaclass->rebless_instance_away( $instance, $self ) + if $old_metaclass; + + my $meta_instance = $self->get_meta_instance; + + # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8 + $meta_instance->rebless_instance_structure( $_[1], $self ); + + for my $attr ( $old_metaclass->get_all_attributes ) { + next if $self->has_attribute( $attr->name ); + $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots; + } + + return $instance; +} + +sub rebless_instance_away { + # this intentionally does nothing, it is just a hook +} + +sub _attach_attribute { + my ($self, $attribute) = @_; + $attribute->attach_to_class($self); +} + +sub _post_add_attribute { + my ( $self, $attribute ) = @_; + + $self->invalidate_meta_instances; + + # invalidate package flag here + try { + local $SIG{__DIE__}; + $attribute->install_accessors; + } + catch { + $self->remove_attribute( $attribute->name ); + die $_; + }; +} + +sub remove_attribute { + my $self = shift; + + my $removed_attribute = $self->SUPER::remove_attribute(@_) + or return; + + $self->invalidate_meta_instances; + + $removed_attribute->remove_accessors; + $removed_attribute->detach_from_class; + + return$removed_attribute; +} + +sub find_attribute_by_name { + my ( $self, $attr_name ) = @_; + + foreach my $class ( $self->linearized_isa ) { + # fetch the meta-class ... + my $meta = Class::MOP::Class->initialize($class); + return $meta->get_attribute($attr_name) + if $meta->has_attribute($attr_name); + } + + return; +} + +sub get_all_attributes { + my $self = shift; + my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } } + reverse $self->linearized_isa; + return values %attrs; +} + # Inheritance sub superclasses { my $self = shift; - my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' }; + + my $isa = $self->get_or_add_package_symbol( + { sigil => '@', type => 'ARRAY', name => 'ISA' } ); + if (@_) { my @supers = @_; - @{$self->get_package_symbol($var_spec)} = @supers; + @{$isa} = @supers; # NOTE: # on 5.8 and below, we need to call @@ -492,61 +802,35 @@ sub superclasses { # we don't know about $self->_check_metaclass_compatibility(); - $self->update_meta_instance_dependencies(); + $self->_superclasses_updated(); } - @{$self->get_package_symbol($var_spec)}; + + return @{$isa}; } -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 ) }; } @@ -579,7 +863,7 @@ sub class_precedence_list { return ( $name, map { - $self->initialize($_)->class_precedence_list() + Class::MOP::Class->initialize($_)->class_precedence_list() } $self->superclasses() ); } @@ -587,52 +871,6 @@ sub class_precedence_list { ## 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) = @_; @@ -649,12 +887,17 @@ sub add_method { # 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; @@ -662,31 +905,31 @@ sub add_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) ); } @@ -704,97 +947,44 @@ sub add_method { # to, and so don't need the fully qualified name. } -sub alias_method { - warn "The alias_method method is deprecated. Use add_method instead.\n"; - - goto &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 = Class::MOP::Class->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; -} -sub compute_all_applicable_methods { - warn 'The compute_all_applicable_methods method is deprecated.' - . " Use get_all_methods instead.\n"; + my %methods; + for my $class ( reverse $self->linearized_isa ) { + my $meta = Class::MOP::Class->initialize($class); + + $methods{ $_->name } = $_ for $meta->_get_local_methods; + } - return map { - { - name => $_->name, - class => $_->package_name, - code => $_, # sigh, overloading - }, - } shift->get_all_methods(@_); + 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 { Class::MOP::Class->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) { # fetch the meta-class ... - my $meta = $self->initialize($class); + my $meta = Class::MOP::Class->initialize($class); push @methods => { name => $method_name, class => $class, @@ -806,58 +996,17 @@ sub find_all_methods_by_name { 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 = Class::MOP::Class->initialize($class)->get_method($method_name); + return $method if defined $method; } return; } -## Attributes - -sub add_attribute { - my $self = shift; - # either we have an attribute object already - # or we need to create one from the args provided - my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_); - # make sure it is derived from the correct type though - ($attribute->isa('Class::MOP::Attribute')) - || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; - - # first we attach our new attribute - # because it might need certain information - # about the class which it is attached to - $attribute->attach_to_class($self); - - # 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); - } else { - $self->invalidate_meta_instances(); - } - - # 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() }; $@ }; - if ( $e ) { - $self->remove_attribute($attribute->name); - die $e; - } - - return $attribute; -} - sub update_meta_instance_dependencies { my $self = shift; @@ -871,12 +1020,13 @@ sub add_meta_instance_dependencies { $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; + my @classes = grep { not $seen{ $_->name }++ } + map { $_->associated_class } @attrs; - foreach my $class ( @classes ) { + foreach my $class (@classes) { $class->add_dependent_meta_instance($self); } @@ -887,7 +1037,7 @@ sub remove_meta_instance_dependencies { my $self = shift; if ( my $classes = delete $self->{meta_instance_dependencies} ) { - foreach my $class ( @$classes ) { + foreach my $class (@$classes) { $class->remove_dependent_meta_instance($self); } @@ -906,12 +1056,14 @@ sub add_dependent_meta_instance { sub remove_dependent_meta_instance { my ( $self, $metaclass ) = @_; my $name = $metaclass->name; - @$_ = grep { $_->name ne $name } @$_ for $self->{dependent_meta_instances}; + @$_ = grep { $_->name ne $name } @$_ + for $self->{dependent_meta_instances}; } sub invalidate_meta_instances { my $self = shift; - $_->invalidate_meta_instance() for $self, @{ $self->{dependent_meta_instances} }; + $_->invalidate_meta_instance() + for $self, @{ $self->{dependent_meta_instances} }; } sub invalidate_meta_instance { @@ -919,199 +1071,244 @@ sub invalidate_meta_instance { undef $self->{_meta_instance}; } -sub has_attribute { - my ($self, $attribute_name) = @_; - (defined $attribute_name && $attribute_name) - || confess "You must define an attribute name"; - exists $self->get_attribute_map->{$attribute_name}; -} +# check if we can reinitialize +sub is_pristine { + my $self = shift; -sub get_attribute { - my ($self, $attribute_name) = @_; - (defined $attribute_name && $attribute_name) - || confess "You must define an attribute name"; - return $self->get_attribute_map->{$attribute_name} - # NOTE: - # this will return undef anyway, so no need ... - # if $self->has_attribute($attribute_name); - #return; + # if any local attr is defined + return if $self->get_attribute_list; + + # or any non-declared methods + 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 remove_attribute { - my ($self, $attribute_name) = @_; - (defined $attribute_name && $attribute_name) - || confess "You must define an attribute name"; - my $removed_attribute = $self->get_attribute_map->{$attribute_name}; - return unless defined $removed_attribute; - delete $self->get_attribute_map->{$attribute_name}; - $self->invalidate_meta_instances(); - $removed_attribute->remove_accessors(); - $removed_attribute->detach_from_class(); - return $removed_attribute; -} - -sub get_attribute_list { - my $self = shift; - keys %{$self->get_attribute_map}; +## Class closing + +sub is_mutable { 1 } +sub is_immutable { 0 } + +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 get_all_attributes { - shift->compute_all_applicable_attributes(@_); +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 compute_all_applicable_attributes { +sub make_mutable { my $self = shift; - my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa; - return values %attrs; + + 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 find_attribute_by_name { - my ($self, $attr_name) = @_; - foreach my $class ($self->linearized_isa) { - # fetch the meta-class ... - my $meta = $self->initialize($class); - return $meta->get_attribute($attr_name) - if $meta->has_attribute($attr_name); +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; } - return; + + my $trait = $args{immutable_trait} = $self->immutable_trait + || confess "no immutable trait specified for $self"; + + my $meta = $self->meta; + my $meta_attr = $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 = $meta->_real_ref_name; + + my $immutable_meta = $meta_name->create( + $class_name, + superclasses => [ ref $self ], + ); + + Class::MOP::MiniTrait::apply( $immutable_meta, $trait ); + + $immutable_meta->make_immutable( + inline_constructor => 0, + inline_accessors => 0, + ); + + return $class_name; } -# check if we can reinitialize -sub is_pristine { +sub _remove_inlined_code { my $self = shift; - # if any local attr is defined - return if $self->get_attribute_list; + $self->remove_method( $_->name ) for $self->_inlined_methods; - # 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); - } - } + delete $self->{__immutable}{inlined_methods}; +} - return 1; +sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } } + +sub _add_inlined_method { + my ( $self, $method ) = @_; + + push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method; } -## Class closing +sub _initialize_immutable { + my ( $self, %args ) = @_; -sub is_mutable { 1 } -sub is_immutable { 0 } + $self->{__immutable}{options} = \%args; + $self->_install_inlined_code(%args); +} -# 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 _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}; +} - my %IMMUTABLE_TRANSFORMERS; - my %IMMUTABLE_OPTIONS; +sub _rebless_as_mutable { + my $self = shift; - 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; + 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 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 _inline_constructor { + my ( $self, %args ) = @_; + + my $name = $args{constructor_name}; + # A class may not even have a constructor, and that's okay. + return unless defined $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; } - sub make_immutable { - my $self = shift; - my %options = @_; + my $constructor_class = $args{constructor_class}; - my $transformer = $self->get_immutable_transformer; - $transformer->make_metaclass_immutable($self, \%options); - $IMMUTABLE_OPTIONS{$self->name} = - { %options, IMMUTABLE_TRANSFORMER => $transformer }; + Class::MOP::load_class($constructor_class); - if( exists $options{debug} && $options{debug} ){ - print STDERR "# of Metaclass options: ", keys %IMMUTABLE_OPTIONS; - print STDERR "# of Immutable transformers: ", keys %IMMUTABLE_TRANSFORMERS; - } + my $constructor = $constructor_class->new( + options => \%args, + metaclass => $self, + is_inline => 1, + package_name => $self->name, + name => $name, + ); - 1; + if ( $args{replace_constructor} or $constructor->can_be_inlined ) { + $self->add_method( $name => $constructor ); + $self->_add_inlined_method($constructor); } +} - 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; +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; } -} -sub create_immutable_transformer { - 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; + 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; @@ -1134,12 +1331,12 @@ Class::MOP::Class - Class Meta Object # 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 ... @@ -1148,8 +1345,8 @@ Class::MOP::Class - Class Meta Object 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 {...}, @@ -1160,11 +1357,11 @@ Class::MOP::Class - Class Meta Object =head1 DESCRIPTION -This 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 documentation for -each of its methods. +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 +documentation for each of its methods. =head1 INHERITANCE @@ -1175,7 +1372,7 @@ C is a subclass of L. =head2 Class construction These methods all create new C 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 @@ -1187,7 +1384,7 @@ existing object. =item B<< Class::MOP::Class->create($package_name, %options) >> This method creates a new C object with the given -package name. It accepts a number of options. +package name. It accepts a number of options: =over 8 @@ -1206,15 +1403,15 @@ An optional array reference of superclass names. =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 optional array reference of L objects. + +=item * no_meta -An attribute can be passed as an existing L -object, I or as a hash reference of options which will be passed -to the attribute metaclass's constructor. +If true, a C method will not be installed into the class. =back @@ -1235,7 +1432,7 @@ All instances of an anonymous class keep a special reference to the 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) >> @@ -1292,23 +1489,46 @@ like constructor parameters and used to initialize the object's attributes. Any existing attributes that are already set will be overwritten. +Before reblessing the instance, this method will call +C on the instance's current metaclass. This method +will be passed the instance, the new metaclass, and any parameters +specified to C. By default, C +does nothing; it is merely a hook. + +=item B<< $metaclass->rebless_instance_back($instance) >> + +Does the same thing as C, except that you can only +rebless an instance into one of its superclasses. Any attributes that +do not exist in the superclass will be deinitialized. + +This is a much more dangerous operation than C, +especially when multiple inheritance is involved, so use this carefully! + =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 for more information on the instance -metaclasses. +metaclass. =item B<< $metaclass->get_meta_instance >> Returns an instance of the C to be used in the construction of a new instance of the class. +=item B<< $metaclass->inline_create_instance($class_var) >> + +This method takes a variable name, and uses it create an inline snippet of +code that will create a new instance of the class. + =back =head2 Informational predicates @@ -1361,7 +1581,13 @@ duplicates removed. =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 @@ -1398,17 +1624,43 @@ 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 objects. - =item B<< $metaclass->get_method_list >> This will return a list of method I for all methods defined in this class. +=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, 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 object for the method. + +=item B<< $metaclass->method_metaclass >> + +Returns the class name of the method metaclass, see +L for more information on the method metaclass. + +=item B<< $metaclass->wrapped_method_metaclass >> + +Returns the class name of the wrapped method metaclass, see +L for more information on the wrapped +method metaclass. + =item B<< $metaclass->get_all_methods >> This will traverse the inheritance hierarchy and return a list of all @@ -1446,27 +1698,6 @@ This method returns the first method in any superclass matching the given name. It is effectively the method that C 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, 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 object for the method. - =back =head2 Attribute introspection and creation @@ -1482,7 +1713,10 @@ attributes which are defined in terms of "regular" Perl 5 methods. This will return a L for the specified C<$attribute_name>. If the class does not have the specified -attribute, it returns C +attribute, it returns C. + +NOTE that get_attribute does not search superclasses, for that you +need to use C. =item B<< $metaclass->has_attribute($attribute_name) >> @@ -1490,29 +1724,22 @@ Returns a boolean indicating whether or not the class defines the 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 objects. - =item B<< $metaclass->get_attribute_list >> This will return a list of attributes I for all attributes -defined in this class. +defined in this class. Note that this operates on the current class +only, it does not traverse the inheritance hierarchy. =item B<< $metaclass->get_all_attributes >> This will traverse the inheritance hierarchy and return a list of all the L objects for this class and its parents. -This method can also be called as C. - =item B<< $metaclass->find_attribute_by_name($attribute_name) >> This will return a L for the specified C<$attribute_name>. If the class does not have the specified -attribute, it returns C +attribute, it returns C. Unlike C, this attribute I look for the named attribute in superclasses. @@ -1520,7 +1747,7 @@ attribute in superclasses. =item B<< $metaclass->add_attribute(...) >> This method accepts either an existing L -object, or parameters suitable for passing to that class's C +object or parameters suitable for passing to that class's C method. The attribute provided will be added to the class. @@ -1545,7 +1772,7 @@ object instances created for this class, not existing instances. =item B<< $metaclass->attribute_metaclass >> Returns the class name of the attribute metaclass for this class. By -default, this is L. for more information on +default, this is L. =back @@ -1559,6 +1786,11 @@ Making a class immutable lets us optimize the class by inlining some 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 and C, will +throw an error on an immutable metaclass object. + The immutabilization system in L takes much greater advantage of the inlining features than Class::MOP itself does. @@ -1566,23 +1798,72 @@ 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 -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. + +=item * constructor_name -=item B<< $metaclass->get_immutable_transformer >> +This is the constructor method name. This defaults to "new". -If the class has been made immutable previously, this returns the -L object that was created to do the -transformation. +=item * constructor_class -If the class was never made immutable, this method will die. +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 @@ -1590,7 +1871,7 @@ If the class was never made immutable, this method will die. Method modifiers are hooks which allow a method to be wrapped with I, I and I 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. @@ -1634,9 +1915,9 @@ order. So the call tree might looks something like this: 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 do as much work as it +The wrapping method does its best to B 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. @@ -1712,7 +1993,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006-2009 by Infinity Interactive, Inc. +Copyright 2006-2010 by Infinity Interactive, Inc. L