X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=d54fdf92b449f4297ca4a7e9f0e001612af65276;hb=bd2550f8320262fe1ab10f6c0eedc960889d869f;hp=df62de7a5e12276baf51c4f47721634143649d85;hpb=4b18c1b3cf8de42c2454663de378e9c3f2180352;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index df62de7..d54fdf9 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -8,17 +8,22 @@ 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', 'reftype', 'weaken'; -use Sub::Name 'subname'; +use Sub::Name 'subname'; use Devel::GlobalDestruction 'in_global_destruction'; +use Try::Tiny; +use List::MoreUtils 'all'; -our $VERSION = '0.91'; +our $VERSION = '1.12'; $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 @@ -41,10 +46,23 @@ sub initialize { || $class->_construct_class_instance(package => $package_name, @_); } -sub construct_class_instance { - Carp::cluck('The construct_class_instance method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"); - shift->_construct_class_instance(@_); +sub reinitialize { + my ( $class, @args ) = @_; + unshift @args, "package" if @args % 2; + my %options = @args; + my $old_metaclass = blessed($options{package}) + ? $options{package} + : Class::MOP::get_metaclass_by_name($options{package}); + $options{weaken} = Class::MOP::metaclass_is_weak($old_metaclass->name) + if !exists $options{weaken} + && blessed($old_metaclass) + && $old_metaclass->isa('Class::MOP::Class'); + $old_metaclass->_remove_generated_metaobjects + if $old_metaclass && $old_metaclass->isa('Class::MOP::Class'); + my $new_metaclass = $class->SUPER::reinitialize(%options); + $new_metaclass->_restore_metaobjects_from($old_metaclass) + if $old_metaclass && $old_metaclass->isa('Class::MOP::Class'); + return $new_metaclass; } # NOTE: (meta-circularity) @@ -69,15 +87,10 @@ 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; @@ -100,11 +113,21 @@ sub _construct_class_instance { # NOTE: # we need to weaken any anon classes # so that they can call DESTROY properly - Class::MOP::weaken_metaclass($package_name) if $meta->is_anon_class; + Class::MOP::weaken_metaclass($package_name) if $options->{weaken}; $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; @@ -126,6 +149,7 @@ sub _new { # should not actually have a value associated # with the slot. 'namespace' => \undef, + 'methods' => {}, # inherited from Class::MOP::Module 'version' => \undef, @@ -134,7 +158,6 @@ sub _new { # defined in Class::MOP::Class 'superclasses' => \undef, - 'methods' => {}, 'attributes' => {}, 'attribute_metaclass' => ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ), @@ -170,47 +193,234 @@ 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 { - Carp::cluck('The check_metaclass_compatibility method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"); - shift->_check_metaclass_compatibility(@_); + sub _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; + + for my $superclass (@superclasses) { + $self->_check_class_metaclass_compatibility($superclass); + } - my @class_list = $self->linearized_isa; - shift @class_list; # shift off $self->name + 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 ); + } + } +} - foreach my $superclass_name (@class_list) { - my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || next; +sub _check_class_metaclass_compatibility { + my $self = shift; + my ( $superclass_name ) = @_; - # 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 "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 "The instance metaclass for " . $self->name . " (" . ($self->instance_metaclass) . ")" . - " is not compatible with the " . - "instance metaclass of its superclass, " . $superclass_name . " (" . ($super_meta->instance_metaclass) . ")"; + 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 _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_name = $super_meta->_real_ref_name; + + return $self->_is_compatible_with($super_meta_name); +} + +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 _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->_is_compatible_with($super_meta->$metaclass_type); +} + +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 _can_fix_metaclass_incompatibility { + my $self = shift; + my ($super_meta) = @_; + + return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta); + + my %base_metaclass = $self->_base_metaclasses; + for my $metaclass_type (keys %base_metaclass) { + return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type); + } + + return; +} + +sub _class_metaclass_can_be_made_compatible { + my $self = shift; + my ($super_meta) = @_; + + return $self->_can_be_made_compatible_with($super_meta->_real_ref_name); +} + +sub _single_metaclass_can_be_made_compatible { + my $self = shift; + my ($super_meta, $metaclass_type) = @_; + + 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 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta); +} + +sub _fix_class_metaclass_incompatibility { + my $self = shift; + my ( $super_meta ) = @_; + + if ($self->_class_metaclass_can_be_made_compatible($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; + + $self->_make_compatible_with($super_meta_name); + } +} + +sub _fix_single_metaclass_incompatibility { + my $self = shift; + my ( $metaclass_type, $super_meta ) = @_; + + if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) { + ($self->is_pristine) + || confess "Can't fix metaclass incompatibility for " + . $self->name + . " because it is not pristine."; + + my $new_metaclass = $self->$metaclass_type + ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type) + : $super_meta->$metaclass_type; + $self->{$metaclass_type} = $new_metaclass; + } +} + +sub _restore_metaobjects_from { + my $self = shift; + my ($old_meta) = @_; + + $self->_restore_metamethods_from($old_meta); + $self->_restore_metaattributes_from($old_meta); +} + +sub _remove_generated_metaobjects { + my $self = shift; + + for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) { + $attr->remove_accessors; } } @@ -238,6 +448,7 @@ sub _check_metaclass_compatibility { sub create_anon_class { my ($class, %options) = @_; + $options{weaken} = 1 unless exists $options{weaken}; my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL; return $class->create($package_name, %options); } @@ -256,6 +467,7 @@ sub _check_metaclass_compatibility { no warnings 'uninitialized'; 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 @@ -297,12 +509,16 @@ sub create { || confess "You must pass a HASH ref of methods" if exists $options{methods}; + $options{meta_name} = 'meta' + unless exists $options{meta_name}; + my (%initialize_options) = @args; delete @initialize_options{qw( package superclasses attributes methods + meta_name version authority )}; @@ -310,10 +526,8 @@ sub create { $meta->_instantiate_module( $options{version}, $options{authority} ); - # FIXME totally lame - $meta->add_method('meta' => sub { - $class->initialize(ref($_[0]) || $_[0]); - }); + $meta->_add_meta_method($options{meta_name}) + if defined $options{meta_name}; $meta->superclasses(@{$options{superclasses}}) if exists $options{superclasses}; @@ -341,18 +555,12 @@ 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'} } -sub _method_map { $_[0]->{'methods'} } - # Instance Construction & Cloning sub new_object { @@ -368,12 +576,6 @@ sub new_object { return $class->_construct_instance(@_); } -sub construct_instance { - Carp::cluck('The construct_instance method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"); - shift->_construct_instance(@_); -} - sub _construct_instance { my $class = shift; my $params = @_ == 1 ? $_[0] : {@_}; @@ -382,21 +584,26 @@ sub _construct_instance { # 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(); + 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) { - (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 - # as a reserved slot name, but right now I am - # going to keep it here. - # my $RESERVED_MOP_SLOT = '__MOP__'; - $instance->{'__MOP__'} = $class; + if (Class::MOP::metaclass_is_weak($class->name)) { + $meta_instance->_set_mop_slot($instance, $class); } return $instance; } @@ -407,12 +614,6 @@ sub get_meta_instance { $self->{'_meta_instance'} ||= $self->_create_meta_instance(); } -sub create_meta_instance { - Carp::cluck('The create_meta_instance method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"); - shift->_create_meta_instance(@_); -} - sub _create_meta_instance { my $self = shift; @@ -427,6 +628,36 @@ sub _create_meta_instance { return $instance; } +sub inline_create_instance { + my $self = shift; + + return $self->get_meta_instance->inline_create_instance(@_); +} + +sub inline_rebless_instance { + my $self = shift; + + return $self->get_meta_instance->inline_rebless_instance_structure(@_); +} + +sub _inline_get_mop_slot { + my $self = shift; + + return $self->get_meta_instance->_inline_get_mop_slot(@_); +} + +sub _inline_set_mop_slot { + my $self = shift; + + return $self->get_meta_instance->_inline_set_mop_slot(@_); +} + +sub _inline_clear_mop_slot { + my $self = shift; + + return $self->get_meta_instance->_inline_clear_mop_slot(@_); +} + sub clone_object { my $class = shift; my $instance = shift; @@ -441,12 +672,6 @@ sub clone_object { $class->_clone_instance($instance, @_); } -sub clone_instance { - Carp::cluck('The clone_instance method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"); - shift->_clone_instance(@_); -} - sub _clone_instance { my ($class, $instance, %params) = @_; (blessed($instance)) @@ -463,30 +688,80 @@ sub _clone_instance { return $clone; } -sub rebless_instance { +sub _force_rebless_instance { my ($self, $instance, %params) = @_; - my $old_metaclass = Class::MOP::class_of($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; - my $meta_instance = $self->get_meta_instance(); + my $meta_instance = $self->get_meta_instance; + + if (Class::MOP::metaclass_is_weak($old_metaclass->name)) { + $meta_instance->_clear_mop_slot($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); + $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params); + + if (Class::MOP::metaclass_is_weak($self->name)) { + $meta_instance->_set_mop_slot($instance, $self); + } +} + +sub rebless_instance { + my ($self, $instance, %params) = @_; + my $old_metaclass = Class::MOP::class_of($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->_force_rebless_instance($_[1], %params); + + return $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."; + + $self->_force_rebless_instance($_[1]); + + return $instance; +} + +sub rebless_instance_away { + # this intentionally does nothing, it is just a hook +} + +sub _fixup_attributes_after_rebless { + my $self = shift; + my ($instance, $rebless_from, %params) = @_; + my $meta_instance = $self->get_meta_instance; + + for my $attr ( $rebless_from->get_all_attributes ) { + next if $self->find_attribute_by_name( $attr->name ); + $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots; + } + 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) unless exists $params{$init_arg}; - } + } else { $attr->set_value($instance, $attr->get_value($instance)); } @@ -496,22 +771,74 @@ sub rebless_instance { 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 +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 @@ -530,12 +857,23 @@ sub superclasses { $self->_check_metaclass_compatibility(); $self->_superclasses_updated(); } - @{$self->get_package_symbol($var_spec)}; + + return @{$isa}; } sub _superclasses_updated { my $self = shift; $self->update_meta_instance_dependencies(); + # keep strong references to all our parents, so they don't disappear if + # they are anon classes and don't have any direct instances + $self->_superclass_metas( + map { Class::MOP::class_of($_) } $self->superclasses + ); +} + +sub _superclass_metas { + my $self = shift; + $self->{_superclass_metas} = [@_]; } sub subclasses { @@ -588,7 +926,7 @@ sub class_precedence_list { return ( $name, map { - $self->initialize($_)->class_precedence_list() + Class::MOP::Class->initialize($_)->class_precedence_list() } $self->superclasses() ); } @@ -596,56 +934,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'); - } - - $method->attach_to_class($self); - $self->_method_map->{$method_name} = $method; - } - else { - # If a raw code reference is supplied, its method object is not created. - # The method object won't be created until required. - $body = $method; - } - - - my ( $current_package, $current_name ) = Class::MOP::get_code_info($body); - - if ( !defined $current_name || $current_name eq '__ANON__' ) { - my $full_method_name = ($self->name . '::' . $method_name); - subname($full_method_name => $body); - } - - $self->add_package_symbol( - { sigil => '&', type => 'CODE', name => $method_name }, - $body, - ); -} - { my $fetch_and_prepare_method = sub { my ($self, $method_name) = @_; @@ -680,7 +968,7 @@ 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( @@ -690,7 +978,7 @@ sub add_method { 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( @@ -700,7 +988,7 @@ sub add_method { 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( @@ -722,89 +1010,12 @@ sub add_method { # to, and so don't need the fully qualified name. } -sub alias_method { - Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n"); - - shift->add_method(@_); -} - -sub _code_is_mine { - my ( $self, $code ) = @_; - - my ( $code_package, $code_name ) = Class::MOP::get_code_info($code); - - return $code_package && $code_package eq $self->name - || ( $code_package eq 'constant' && $code_name eq '__ANON__' ); -} - -sub has_method { - my ($self, $method_name) = @_; - (defined $method_name && $method_name) - || confess "You must define a method name"; - - return defined($self->get_method($method_name)); -} - -sub get_method { - my ($self, $method_name) = @_; - (defined $method_name && $method_name) - || confess "You must define a method name"; - - my $method_map = $self->_method_map; - my $method_object = $method_map->{$method_name}; - my $code = $self->get_package_symbol({ - name => $method_name, - sigil => '&', - type => 'CODE', - }); - - unless ( $method_object && $method_object->body == ( $code || 0 ) ) { - if ( $code && $self->_code_is_mine($code) ) { - $method_object = $method_map->{$method_name} - = $self->wrap_method_body( - body => $code, - name => $method_name, - associated_metaclass => $self, - ); - } - else { - delete $method_map->{$method_name}; - return undef; - } - } - - return $method_object; -} - -sub remove_method { - 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; - return grep { $self->has_method($_) } keys %{ $self->namespace }; -} - 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) { - my $method = $self->initialize($class)->get_method($method_name); + my $method = Class::MOP::Class->initialize($class)->get_method($method_name); return $method if defined $method; } return; @@ -812,37 +1023,31 @@ sub find_method_by_name { 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 { - Carp::cluck('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; - return grep { !$uniq{$_}++ } map { $self->initialize($_)->get_method_list } $self->linearized_isa; + 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, @@ -854,68 +1059,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) { - my $method = $self->initialize($class)->get_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); - - 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($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->get_attribute_map}); - $attribute->_set_insertion_order($order); - - # then onto installing the new accessors - $self->get_attribute_map->{$attr_name} = $attribute; - - # invalidate package flag here - my $e = do { - local $@; - local $SIG{__DIE__}; - eval { $attribute->install_accessors() }; - $@; - }; - if ( $e ) { - $self->remove_attribute($attr_name); - die $e; - } - - return $attribute; -} - sub update_meta_instance_dependencies { my $self = shift; @@ -932,9 +1086,10 @@ sub add_meta_instance_dependencies { 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); } @@ -945,7 +1100,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); } @@ -964,12 +1119,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 { @@ -977,66 +1134,6 @@ 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}; -} - -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; -} - -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}; -} - -sub get_all_attributes { - my $self = shift; - my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa; - return values %attrs; -} - -sub compute_all_applicable_attributes { - Carp::cluck('The compute_all_applicable_attributes method has been deprecated.' - . " Use get_all_attributes instead.\n"); - - shift->get_all_attributes(@_); -} - -sub find_attribute_by_name { - my ($self, $attr_name) = @_; - foreach my $class ($self->linearized_isa) { - # fetch the meta-class ... - my $meta = $self->initialize($class); - return $meta->get_attribute($attr_name) - if $meta->has_attribute($attr_name); - } - return; -} - # check if we can reinitialize sub is_pristine { my $self = shift; @@ -1045,12 +1142,9 @@ sub is_pristine { 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; @@ -1061,6 +1155,8 @@ sub is_pristine { sub is_mutable { 1 } sub is_immutable { 0 } +sub immutable_options { %{ $_[0]{__immutable}{options} || {} } } + sub _immutable_options { my ( $self, @args ) = @_; @@ -1145,27 +1241,14 @@ sub _immutable_metaclass { # 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 $meta_name = $meta->_real_ref_name; 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 ); - } - } + Class::MOP::MiniTrait::apply( $immutable_meta, $trait ); $immutable_meta->make_immutable( inline_constructor => 0, @@ -1210,7 +1293,7 @@ sub _install_inlined_code { sub _rebless_as_mutable { my $self = shift; - bless $self, $self->get_mutable_metaclass_name; + bless $self, $self->_get_mutable_metaclass_name; return $self; } @@ -1227,6 +1310,8 @@ 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; @@ -1338,7 +1423,7 @@ Class::MOP::Class - Class Meta Object 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 @@ -1350,7 +1435,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 @@ -1362,7 +1447,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 @@ -1381,12 +1466,33 @@ 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 L objects. +=item * meta_name + +Specifies the name to install the C method for this class under. +If it is not passed, C is assumed, and if C is explicitly +given, no meta method will be installed. + +=item * weaken + +If true, the metaclass that is stored in the global cache will be a +weak reference. + +Classes created in this way are destroyed once the metaclass they are +attached to goes out of scope, and will be removed from Perl's internal +symbol table. + +All instances of a class with a weakened metaclass 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 is based on a hash reference, however. + =back =item B<< Class::MOP::Class->create_anon_class(%options) >> @@ -1398,15 +1504,8 @@ that name is a unique name generated internally by this module. It accepts the same C, C, and C parameters that C accepts. -Anonymous classes are destroyed once the metaclass they are attached -to goes out of scope, and will be removed from Perl's internal symbol -table. - -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. +Anonymous classes default to C<< weaken => 1 >>, although this can be +overridden. =item B<< Class::MOP::Class->initialize($package_name, %options) >> @@ -1469,6 +1568,15 @@ 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 @@ -1476,12 +1584,11 @@ class. Any parameters you provide are used to initialize the instance's attributes. A special C<__INSTANCE__> key can be passed to provide an already generated instance, rather than having Class::MOP generate it for you. This is mostly useful for using Class::MOP with -foreign classes, which generally generate instances using their own -constructor. +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 metaclass. @@ -1490,6 +1597,13 @@ metaclass. 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) >> + +=item B<< $metaclass->inline_rebless_instance($instance_var, $class_var) >> + +These methods takes variable names, and use them to create an inline snippet +of code that will create a new instance of the class. + =back =head2 Informational predicates @@ -1585,17 +1699,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 @@ -1633,38 +1773,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. - -=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. - =back =head2 Attribute introspection and creation @@ -1691,16 +1799,11 @@ 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 >> @@ -1711,7 +1814,7 @@ the L objects for this class and its parents. 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. @@ -1719,7 +1822,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. @@ -1744,7 +1847,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 @@ -1758,11 +1861,10 @@ 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 such as C and -C. Methods which would alter the class, such as -C, C, and so on will throw an error on an -immutable metaclass object. +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. @@ -1771,7 +1873,7 @@ 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. This method accepts the following options: @@ -1827,6 +1929,13 @@ 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. @@ -1837,7 +1946,7 @@ Calling this method reverse the immutabilization transformation. 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. @@ -1881,9 +1990,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. @@ -1959,7 +2068,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