use Try::Tiny;
use List::MoreUtils 'all';
-our $VERSION = '1.08';
+our $VERSION = '1.11';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
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;
# 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;
}
}, $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 = (
}
}
-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 ) = @_;
}
}
-sub _single_metaclass_is_compatible {
+sub _class_metaclass_is_compatible {
my $self = shift;
- my ( $metaclass_type, $superclass_name ) = @_;
+ my ( $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;
+ my $super_meta_name = $super_meta->_real_ref_name;
- return $self->$metaclass_type->isa($super_meta->$metaclass_type);
+ return $self->_is_compatible_with($super_meta_name);
}
sub _check_single_metaclass_compatibility {
}
}
-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 {
+sub _single_metaclass_is_compatible {
my $self = shift;
- my ($metaclass_type, $super_meta) = @_;
+ my ( $metaclass_type, $superclass_name ) = @_;
- my $specific_meta = $self->$metaclass_type;
- return unless $super_meta->can($metaclass_type);
- my $super_specific_meta = $super_meta->$metaclass_type;
+ 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 unless defined $super_specific_meta;
-
- # if metaclass is defined in superclass but not here, it's fixable
+ 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 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;
-}
+ return 0 unless defined $self->$metaclass_type;
-sub _can_fix_metaclass_incompatibility {
- my $self = shift;
- return $self->_can_fix_metaclass_incompatibility_by_subclassing(@_);
+ return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type);
}
sub _fix_metaclass_incompatibility {
}
}
-sub _fix_class_metaclass_incompatibility {
+sub _can_fix_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) = @_;
- my $super_meta_name = $super_meta->_real_ref_name;
+ return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta);
- $super_meta_name->meta->rebless_instance($self);
+ 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 _fix_single_metaclass_incompatibility {
+sub _class_metaclass_can_be_made_compatible {
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.";
+ my ($super_meta) = @_;
- $self->{$metaclass_type} = $super_meta->$metaclass_type;
- }
+ return $self->_can_be_made_compatible_with($super_meta->_real_ref_name);
}
-sub _get_associated_single_metaclass {
+sub _single_metaclass_can_be_made_compatible {
my $self = shift;
- my ($single_meta_name) = @_;
+ my ($super_meta, $metaclass_type) = @_;
- 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;
-}
+ my $specific_meta = $self->$metaclass_type;
-sub _get_compatible_single_metaclass_by_subclassing {
- my $self = shift;
- my ($single_meta_name) = @_;
+ return unless $super_meta->can($metaclass_type);
+ my $super_specific_meta = $super_meta->$metaclass_type;
- my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name);
+ # 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 ($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;
- }
+ # 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;
+ return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta);
}
-sub _get_compatible_single_metaclass {
+sub _fix_class_metaclass_incompatibility {
my $self = shift;
- my ($single_meta_name) = @_;
+ my ( $super_meta ) = @_;
- return $self->_get_compatible_single_metaclass_by_subclassing($single_meta_name);
+ 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 _make_metaobject_compatible {
+sub _fix_single_metaclass_incompatibility {
my $self = shift;
- my ($object) = @_;
+ my ( $metaclass_type, $super_meta ) = @_;
- my $new_metaclass = $self->_get_compatible_single_metaclass(blessed($object));
+ 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.";
- if (!defined($new_metaclass)) {
- confess "Can't make $object compatible with metaclass "
- . $self->_get_associated_single_metaclass(blessed($object));
+ 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;
}
-
- # XXX: is this sufficient? i think so... we should never lose attributes
- # by this process
- bless($object, $new_metaclass)
- if blessed($object) ne $new_metaclass;
-
- return $object;
}
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 {
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);
}
|| 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
)};
$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};
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 {
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;
+
+ my $idx = 0;
+ return (
+ 'my $class = shift;',
+ 'return Class::MOP::Class->initialize($class)->new_object(@_)',
+ 'if $class ne \'' . $self->name . '\';',
+ 'my $params = @_ == 1 ? $_[0] : {@_};',
+ 'my $instance = ' . $self->_inline_create_instance('$class') . ';',
+ (map { $self->_inline_slot_initializer($_, $idx++) }
+ $self->get_all_attributes),
+ $self->_inline_preserve_weak_metaclasses,
+ 'return $instance',
+ );
+}
+
+sub _inline_create_instance {
+ my $self = shift;
+
+ return $self->get_meta_instance->inline_create_instance(@_);
+}
+
+sub _inline_slot_initializer {
+ my $self = shift;
+ my ($attr, $idx) = @_;
+
+ my $default = $self->_inline_default_value($attr, $idx);
+
+ if (defined(my $init_arg = $attr->init_arg)) {
+ my @source = (
+ 'if (exists $params->{\'' . $init_arg . '\'}) {',
+ $attr->_inline_set_value(
+ '$instance', '$params->{\'' . $init_arg . '\'}'
+ ),
+ '}',
+ );
+ if (defined $default) {
+ push @source, (
+ 'else {',
+ $attr->_inline_set_value('$instance', $default),
+ '}',
+ );
+ }
+ return @source;
+ }
+ elsif (defined $default) {
+ return $attr->_inline_set_value('$instance', $default);
+ }
+ else {
+ return ();
+ }
+}
+
+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 get_meta_instance {
my $self = shift;
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 {
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);
- 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));
- }
- }
- }
+ $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params);
- foreach my $attr ($self->get_all_attributes) {
- $attr->initialize_instance_slot($meta_instance, $instance, \%params);
+ if (Class::MOP::metaclass_is_weak($self->name)) {
+ $meta_instance->_set_mop_slot($instance, $self);
}
-
- $instance;
+}
+
+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
. $self->name
. ") isn't.";
- $old_metaclass->rebless_instance_away( $instance, $self )
- if $old_metaclass;
+ $self->_force_rebless_instance($_[1]);
- my $meta_instance = $self->get_meta_instance;
+ return $instance;
+}
- # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
- $meta_instance->rebless_instance_structure( $_[1], $self );
+sub rebless_instance_away {
+ # this intentionally does nothing, it is just a hook
+}
- for my $attr ( $old_metaclass->get_all_attributes ) {
- next if $self->has_attribute( $attr->name );
+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;
}
- return $instance;
-}
+ 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));
+ }
+ }
+ }
-sub rebless_instance_away {
- # this intentionally does nothing, it is just a hook
+ foreach my $attr ($self->get_all_attributes) {
+ $attr->initialize_instance_slot($meta_instance, $instance, \%params);
+ }
}
sub _attach_attribute {
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 = @_;
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 {
An optional array reference of L<Class::MOP::Attribute> objects.
-=item * no_meta
+=item * meta_name
+
+Specifies the name to install the C<meta> method for this class under.
+If it is not passed, C<meta> is assumed, and if C<undef> 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.
-If true, a C<meta> method will not be installed into the class.
+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
It accepts the same C<superclasses>, C<methods>, and C<attributes>
parameters that C<create> 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) >>
Returns an instance of the C<instance_metaclass> 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
projects / gitmo/Class-MOP.git / blobdiff