use Carp 'confess';
use Scalar::Util 'blessed', 'reftype';
-use Hash::Util 'lock_keys';
use Sub::Name 'subname';
use B 'svref_2object';
+use Clone ();
our $VERSION = '0.03';
|| confess "You must pass a package name";
return $METAS{$package_name} if exists $METAS{$package_name};
$class = blessed($class) || $class;
+ # now create the metaclass
+ my $meta;
if ($class =~ /^Class::MOP::/) {
- $METAS{$package_name} = bless {
+ $meta = bless {
'$:package' => $package_name,
'%:attributes' => {},
- '$:attribute_metaclass' => 'Class::MOP::Attribute',
- '$:method_metaclass' => 'Class::MOP::Method',
+ '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute',
+ '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method',
} => $class;
}
else {
# it is safe to use meta here because
# class will always be a subclass of
# Class::MOP::Class, which defines meta
- $METAS{$package_name} = bless $class->meta->construct_instance(%options) => $class
+ $meta = bless $class->meta->construct_instance(%options) => $class
}
+ # and check the metaclass compatibility
+ $meta->check_metaclass_compatability();
+ $METAS{$package_name} = $meta;
+ }
+
+ sub check_metaclass_compatability {
+ my $self = shift;
+
+ # this is always okay ...
+ return if blessed($self) eq 'Class::MOP::Class';
+
+ my @class_list = $self->class_precedence_list;
+ shift @class_list; # shift off $self->name
+
+ foreach my $class_name (@class_list) {
+ next unless $METAS{$class_name};
+ my $meta = $METAS{$class_name};
+ ($self->isa(blessed($meta)))
+ || confess $self->name . "->meta => (" . (blessed($self)) . ")" .
+ " is not compatible with the " .
+ $class_name . "->meta => (" . (blessed($meta)) . ")";
+ }
}
}
# NOTE:
# we need to protect the integrity of the
# Class::MOP::Class singletons here, they
- # should not be cloned
+ # should not be cloned.
return $instance if $instance->isa('Class::MOP::Class');
bless $class->clone_instance($instance, @_) => blessed($instance);
}
-#{
-# sub _deep_clone {
-# my ($object, $cache) = @_;
-# return $object unless ref($object);
-# # check for an active cache
-# return _deep_clone_ref($object, ($cache = {}), 'HASH') if not defined $cache;
-# # if we have it in the cache them return the cached clone
-# return $cache->{$object} if exists $cache->{$object};
-# # now try it as an object, which will in
-# # turn try it as ref if its not an object
-# # and store it in case we run into a circular ref
-# $cache->{$object} = _deep_clone_object($object, $cache);
-# }
-#
-# sub _deep_clone_object {
-# my ($object, $cache) = @_;
-# # check to see if its an object, with a clone method
-# # or if we have an object, with no clone method, then
-# # we will respect its encapsulation, and not muck with
-# # its internals. Basically, we assume it does not want
-# # to be cloned
-# return $cache->{$object} = ($object->can('clone') ? $object->clone() : $object)
-# if blessed($object);
-# return $cache->{$object} = _deep_clone_ref($object, $cache);
-# }
-#
-# sub _deep_clone_ref {
-# my ($object, $cache, $ref_type) = @_;
-# $ref_type ||= ref($object);
-# my ($clone, $tied);
-# if ($ref_type eq 'HASH') {
-# $clone = {};
-# tie %{$clone}, ref $tied if $tied = tied(%{$object});
-# %{$clone} = map { ref($_) ? _deep_clone($_, $cache) : $_ } %{$object};
-# }
-# elsif ($ref_type eq 'ARRAY') {
-# $clone = [];
-# tie @{$clone}, ref $tied if $tied = tied(@{$object});
-# @{$clone} = map { ref($_) ? _deep_clone($_, $cache) : $_ } @{$object};
-# }
-# elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') {
-# my $var = "";
-# $clone = \$var;
-# tie ${$clone}, ref $tied if $tied = tied(${$object});
-# ${$clone} = _deep_clone(${$object}, $cache);
-# }
-# else {
-# # shallow copy reference to code, glob, regex
-# $clone = $object;
-# }
-# # store it in our cache
-# $cache->{$object} = $clone;
-# # and return the clone
-# return $clone;
-# }
-#}
-
sub clone_instance {
my ($class, $instance, %params) = @_;
(blessed($instance))
|| confess "You can only clone instances, \$self is not a blessed instance";
# NOTE:
- # this should actually do a deep clone
- # instead of this cheap hack. I will
- # add that in later.
- # (use the Class::Cloneable::Util code)
- my $clone = { %{$instance} }; #_deep_clone($instance);
+ # This will deep clone, which might
+ # not be what you always want. So
+ # the best thing is to write a more
+ # controled &clone method locally
+ # in the class (see Class::MOP)
+ my $clone = Clone::clone($instance);
foreach my $attr ($class->compute_all_applicable_attributes()) {
my $init_arg = $attr->init_arg();
# try to fetch the init arg from the %params ...
method is used internally by C<initialize> and should never be called
from outside of that method really.
+=item B<check_metaclass_compatability>
+
+This method is called as the very last thing in the
+C<construct_class_instance> method. This will check that the
+metaclass you are creating is compatible with the metaclasses of all
+your ancestors. For more inforamtion about metaclass compatibility
+see the C<About Metaclass compatibility> section in L<Class::MOP>.
+
=back
=head2 Object instance construction and cloning
projects / gitmo/Class-MOP.git / blobdiff