X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=26d4bdabe3ab206753538312e540b74ef9152ee3;hb=398a82df319a28b66dfd22e98c87a0adfb12c83f;hp=8a7473f61c66b3bbea19b614ee30f6abd84a4502;hpb=e6e93343be33a87d193739755ee4dc0d71be65c3;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 8a7473f..26d4bda 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -17,7 +17,7 @@ use Devel::GlobalDestruction 'in_global_destruction'; use Try::Tiny; use List::MoreUtils 'all'; -our $VERSION = '1.08'; +our $VERSION = '1.11'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -53,9 +53,13 @@ sub reinitialize { 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(@args); + 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; @@ -109,7 +113,7 @@ 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; } @@ -177,18 +181,6 @@ sub _new { }, $class; } -sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef } -sub update_package_cache_flag { - my $self = shift; - # NOTE: - # we can manually update the cache number - # since we are actually adding the method - # to our cache as well. This avoids us - # having to regenerate the method_map. - # - SL - $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); -} - ## Metaclass compatibility { my %base_metaclass = ( @@ -258,9 +250,9 @@ sub _class_metaclass_is_compatible { my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || return 1; - my $super_meta_type = $super_meta->_real_ref_name; + my $super_meta_name = $super_meta->_real_ref_name; - return $self->isa($super_meta_type); + return $self->_is_compatible_with($super_meta_name); } sub _check_single_metaclass_compatibility { @@ -298,7 +290,7 @@ sub _single_metaclass_is_compatible { # this is a really odd case return 0 unless defined $self->$metaclass_type; - return $self->$metaclass_type->isa($super_meta->$metaclass_type); + return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type); } sub _fix_metaclass_incompatibility { @@ -332,38 +324,31 @@ sub _fix_metaclass_incompatibility { sub _can_fix_metaclass_incompatibility { my $self = shift; - return $self->_can_fix_metaclass_incompatibility_by_subclassing(@_); -} - -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); + 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->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta); + return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type); } return; } -sub _can_fix_class_metaclass_incompatibility_by_subclassing { +sub _class_metaclass_can_be_made_compatible { 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)); + return $self->_can_be_made_compatible_with($super_meta->_real_ref_name); } -sub _can_fix_single_metaclass_incompatibility_by_subclassing { +sub _single_metaclass_can_be_made_compatible { my $self = shift; - my ($metaclass_type, $super_meta) = @_; + 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; @@ -375,15 +360,14 @@ sub _can_fix_single_metaclass_incompatibility_by_subclassing { # 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); + 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->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta)) { + if ($self->_class_metaclass_can_be_made_compatible($super_meta)) { ($self->is_pristine) || confess "Can't fix metaclass incompatibility for " . $self->name @@ -391,7 +375,7 @@ sub _fix_class_metaclass_incompatibility { my $super_meta_name = $super_meta->_real_ref_name; - $super_meta_name->meta->rebless_instance($self); + $self->_make_compatible_with($super_meta_name); } } @@ -399,13 +383,16 @@ 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)) { + 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."; - $self->{$metaclass_type} = $super_meta->$metaclass_type; + 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; } } @@ -413,17 +400,8 @@ sub _restore_metaobjects_from { my $self = shift; my ($old_meta) = @_; - for my $method ($old_meta->_get_local_methods) { - $self->_make_metaobject_compatible($method); - $self->add_method($method->name => $method); - } - - for my $attr (sort { $a->insertion_order <=> $b->insertion_order } - map { $old_meta->get_attribute($_) } - $old_meta->get_attribute_list) { - $self->_make_metaobject_compatible($attr); - $self->add_attribute($attr); - } + $self->_restore_metamethods_from($old_meta); + $self->_restore_metaattributes_from($old_meta); } sub _remove_generated_metaobjects { @@ -434,67 +412,6 @@ sub _remove_generated_metaobjects { } } -sub _make_metaobject_compatible { - my $self = shift; - my ($object) = @_; - - my $new_metaclass = $self->_get_compatible_single_metaclass(blessed($object)); - - if (!defined($new_metaclass)) { - confess "Can't make $object compatible with metaclass " - . $self->_get_associated_single_metaclass(blessed($object)); - } - - # can't use rebless_instance here, because it might not be an actual - # subclass in the case of, e.g. moose role reconciliation - $new_metaclass->meta->_force_rebless_instance($object) - if blessed($object) ne $new_metaclass; - - return $object; -} - -sub _get_associated_single_metaclass { - my $self = shift; - my ($single_meta_name) = @_; - - my $current_single_meta_name; - if ($single_meta_name->isa('Class::MOP::Method')) { - $current_single_meta_name = $self->method_metaclass; - } - elsif ($single_meta_name->isa('Class::MOP::Attribute')) { - $current_single_meta_name = $self->attribute_metaclass; - } - else { - confess "Can't make $single_meta_name compatible, it isn't an " - . "attribute or method metaclass."; - } - - return $current_single_meta_name; -} - -sub _get_compatible_single_metaclass { - my $self = shift; - my ($single_meta_name) = @_; - - return $self->_get_compatible_single_metaclass_by_subclassing($single_meta_name); -} - -sub _get_compatible_single_metaclass_by_subclassing { - my $self = shift; - my ($single_meta_name) = @_; - - my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name); - - if ($single_meta_name->isa($current_single_meta_name)) { - return $single_meta_name; - } - elsif ($current_single_meta_name->isa($single_meta_name)) { - return $current_single_meta_name; - } - - return; -} - ## ANON classes { @@ -519,6 +436,7 @@ sub _get_compatible_single_metaclass_by_subclassing { 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); } @@ -579,13 +497,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 - no_meta + meta_name version authority )}; @@ -593,18 +514,8 @@ sub create { $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->_add_meta_method($options{meta_name}) + if defined $options{meta_name}; $meta->superclasses(@{$options{superclasses}}) if exists $options{superclasses}; @@ -626,18 +537,6 @@ sub create { return $meta; } -## Attribute readers - -# NOTE: -# all these attribute readers will be bootstrapped -# away in the Class::MOP bootstrap section - -sub instance_metaclass { $_[0]->{'instance_metaclass'} } -sub immutable_trait { $_[0]->{'immutable_trait'} } -sub constructor_class { $_[0]->{'constructor_class'} } -sub constructor_name { $_[0]->{'constructor_name'} } -sub destructor_class { $_[0]->{'destructor_class'} } - # Instance Construction & Cloning sub new_object { @@ -679,21 +578,184 @@ sub _construct_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; } +sub _inline_new_object { + my $self = shift; + + return ( + 'my $class = shift;', + '$class = Scalar::Util::blessed($class) || $class;', + $self->_inline_fallback_constructor('$class'), + $self->_inline_params('$params', '$class'), + $self->_inline_generate_instance('$instance', '$class'), + $self->_inline_slot_initializers, + $self->_inline_preserve_weak_metaclasses, + $self->_inline_extra_init, + 'return $instance', + ); +} + +sub _inline_fallback_constructor { + my $self = shift; + my ($class) = @_; + return ( + 'return ' . $self->_generate_fallback_constructor($class), + 'if ' . $class . ' ne \'' . $self->name . '\';', + ); +} + +sub _generate_fallback_constructor { + my $self = shift; + my ($class) = @_; + return 'Class::MOP::Class->initialize(' . $class . ')->new_object(@_)', +} + +sub _inline_params { + my $self = shift; + my ($params, $class) = @_; + return ( + 'my ' . $params . ' = @_ == 1 ? $_[0] : {@_};', + ); +} + +sub _inline_generate_instance { + my $self = shift; + my ($inst, $class) = @_; + return ( + 'my ' . $inst . ' = ' . $self->_inline_create_instance($class) . ';', + ); +} + +sub _inline_create_instance { + my $self = shift; + + return $self->get_meta_instance->inline_create_instance(@_); +} + +sub _inline_slot_initializers { + my $self = shift; + + my $idx = 0; + + return map { $self->_inline_slot_initializer($_, $idx++) } + sort { $a->name cmp $b->name } $self->get_all_attributes; +} + +sub _inline_slot_initializer { + my $self = shift; + my ($attr, $idx) = @_; + + if (defined(my $init_arg = $attr->init_arg)) { + my @source = ( + 'if (exists $params->{\'' . $init_arg . '\'}) {', + $self->_inline_init_attr_from_constructor($attr, $idx), + '}', + ); + if (my @default = $self->_inline_init_attr_from_default($attr, $idx)) { + push @source, ( + 'else {', + @default, + '}', + ); + } + return @source; + } + elsif (my @default = $self->_inline_init_attr_from_default($attr, $idx)) { + return ( + '{', + @default, + '}', + ); + } + else { + return (); + } +} + +sub _inline_init_attr_from_constructor { + my $self = shift; + my ($attr, $idx) = @_; + + my @initial_value = $attr->_inline_set_value( + '$instance', '$params->{\'' . $attr->init_arg . '\'}', + ); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_init_attr_from_default { + my $self = shift; + my ($attr, $idx) = @_; + + my $default = $self->_inline_default_value($attr, $idx); + return unless $default; + + my @initial_value = $attr->_inline_set_value('$instance', $default); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_default_value { + my $self = shift; + my ($attr, $index) = @_; + + if ($attr->has_default) { + # NOTE: + # default values can either be CODE refs + # in which case we need to call them. Or + # they can be scalars (strings/numbers) + # in which case we can just deal with them + # in the code we eval. + if ($attr->is_default_a_coderef) { + return '$defaults->[' . $index . ']->($instance)'; + } + else { + return '$defaults->[' . $index . ']'; + } + } + elsif ($attr->has_builder) { + return '$instance->' . $attr->builder; + } + else { + return; + } +} + +sub _inline_preserve_weak_metaclasses { + my $self = shift; + if (Class::MOP::metaclass_is_weak($self->name)) { + return ( + $self->_inline_set_mop_slot( + '$instance', 'Class::MOP::class_of($class)' + ) . ';' + ); + } + else { + return (); + } +} + +sub _inline_extra_init { } + sub get_meta_instance { my $self = shift; @@ -714,16 +776,28 @@ sub _create_meta_instance { return $instance; } -sub inline_create_instance { +sub _inline_rebless_instance { my $self = shift; - return $self->get_meta_instance->inline_create_instance(@_); + return $self->get_meta_instance->inline_rebless_instance_structure(@_); } -sub inline_rebless_instance { +sub _inline_get_mop_slot { my $self = shift; - return $self->get_meta_instance->inline_rebless_instance_structure(@_); + 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 { @@ -765,11 +839,19 @@ sub _force_rebless_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 { @@ -893,8 +975,7 @@ sub get_all_attributes { sub superclasses { my $self = shift; - my $isa = $self->get_or_add_package_symbol( - { sigil => '@', type => 'ARRAY', name => 'ISA' } ); + my $isa = $self->get_or_add_package_symbol('@ISA'); if (@_) { my @supers = @_; @@ -924,6 +1005,16 @@ sub superclasses { 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 { @@ -1522,9 +1613,26 @@ hash reference are method names and values are subroutine references. An optional array reference of L objects. -=item * no_meta +=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, a C method will not be installed into the class. +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 @@ -1537,15 +1645,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 is 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) >> @@ -1637,13 +1738,6 @@ 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