use Class::MOP::Method::Wrapped;
use Class::MOP::Method::Accessor;
use Class::MOP::Method::Constructor;
-use Class::MOP::Class::Immutable::Class::MOP::Class;
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
use Sub::Name 'subname';
use Devel::GlobalDestruction 'in_global_destruction';
-our $VERSION = '0.87';
+our $VERSION = '0.89';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
: ref($super_meta);
($self->isa($super_meta_type))
- || confess "Class::MOP::class_of(" . $self->name . ") => ("
+ || confess "The metaclass of " . $self->name . " ("
. (ref($self)) . ")" . " is not compatible with the " .
- "Class::MOP::class_of(".$superclass_name . ") => ("
+ "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 "Class::MOP::class_of(" . $self->name . ")->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
+ || confess "The instance metaclass for " . $self->name . " (" . ($self->instance_metaclass) . ")" .
" is not compatible with the " .
- "Class::MOP::class_of(" . $superclass_name . ")->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")";
+ "instance metaclass of its superclass, " . $superclass_name . " (" . ($super_meta->instance_metaclass) . ")";
}
}
return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
no warnings 'uninitialized';
- return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
+ my $name = $self->name;
+ return unless $name =~ /^$ANON_CLASS_PREFIX/;
# Moose does a weird thing where it replaces the metaclass for
# class when fixing metaclass incompatibility. In that case,
# we don't want to clean out the namespace now. We can detect
# that because Moose will explicitly update the singleton
# cache in Class::MOP.
- my $current_meta = Class::MOP::get_metaclass_by_name($self->name);
+ my $current_meta = Class::MOP::get_metaclass_by_name($name);
return if $current_meta ne $self;
- my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
+ my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/);
no strict 'refs';
- foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) {
- delete ${$ANON_CLASS_PREFIX . $serial_id}{$key};
- }
- delete ${'main::' . $ANON_CLASS_PREFIX}{$serial_id . '::'};
+ @{$name . '::ISA'} = ();
+ %{$name . '::'} = ();
+ delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
+
+ Class::MOP::remove_metaclass_by_name($name);
}
}
sub constructor_name { $_[0]->{'constructor_name'} }
sub destructor_class { $_[0]->{'destructor_class'} }
+sub _method_map { $_[0]->{'methods'} }
+
# Instance Construction & Cloning
sub new_object {
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;
- $method = $self->wrap_method_body( body => $body, name => $method_name );
}
- $method->attach_to_class($self);
-
- $self->get_method_map->{$method_name} = $method;
my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
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";
- exists $self->get_method_map->{$method_name};
+ return defined($self->get_method($method_name));
}
sub get_method {
(defined $method_name && $method_name)
|| confess "You must define a method name";
- return $self->get_method_map->{$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',
+ });
+
+ if (!($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 {
$trait, 'ForMetaClass', ref($self);
}
- if ( Class::MOP::is_class_loaded($class_name) ) {
- if ( $class_name->isa($trait) ) {
- return $class_name;
+ return $class_name
+ if Class::MOP::is_class_loaded($class_name);
+
+ # If the metaclass is a subclass of CMOP::Class which has had
+ # metaclass roles applied (via Moose), then we want to make sure
+ # that we preserve that anonymous class (see Fey::ORM for an
+ # example of where this matters).
+ my $meta_name
+ = $self->meta->is_immutable
+ ? $self->meta->get_mutable_metaclass_name
+ : ref $self->meta;
+
+ my $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 ) {
+ next if $meta->has_method( $meth->name );
+
+ if ( $meta->find_method_by_name( $meth->name ) ) {
+ $meta->add_around_method_modifier( $meth->name, $meth->body );
}
else {
- confess
- "$class_name is already defined but does not inherit $trait";
+ $meta->add_method( $meth->name, $meth->clone );
}
}
- else {
- my @super = ( $trait, ref($self) );
- my $meta = Class::MOP::Class->initialize($class_name);
- $meta->superclasses(@super);
+ $meta->make_immutable( inline_constructor => 0 );
- $meta->make_immutable;
-
- return $class_name;
- }
+ return $class_name;
}
sub _remove_inlined_code {
This method is used to create a new object of the metaclass's
class. Any parameters you provide are used to initialize the
-instance's attributes.
+instance's attributes. A special C<__INSTANCE__> key can be passed to
+provide an already generated instance, rather than having Class::MOP
+generate it for you. This is mostly useful for using Class::MOP with
+foreign classes, which generally generate instances using their own
+constructor.
=item B<< $metaclass->instance_metaclass >>
projects / gitmo/Class-MOP.git / blobdiff