use Class::MOP::Method::Wrapped;
use Carp 'confess';
-use Scalar::Util 'blessed', 'reftype', 'weaken';
+use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.32';
+our $VERSION = '0.33';
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Module';
my $package_name = shift;
(defined $package_name && $package_name && !blessed($package_name))
|| confess "You must pass a package name and it cannot be blessed";
- if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
- return $meta;
- }
- $class->construct_class_instance('package' => $package_name, @_);
+ return Class::MOP::get_metaclass_by_name($package_name)
+ || $class->construct_class_instance('package' => $package_name, @_);
}
sub reinitialize {
# we can tell the first time the
# methods are fetched
# - SL
- '$!_package_cache_flag' => undef,
+ '$!_package_cache_flag' => undef,
+ '$!_meta_instance' => undef,
} => $class;
}
else {
my @class_list = $self->linearized_isa;
shift @class_list; # shift off $self->name
- my $name = $self->name;
-
foreach my $class_name (@class_list) {
my $meta = Class::MOP::get_metaclass_by_name($class_name) || next;
: blessed($meta));
($self->isa($meta_type))
- || confess $name . "->meta => (" . (blessed($self)) . ")" .
+ || confess $self->name . "->meta => (" . (blessed($self)) . ")" .
" is not compatible with the " .
$class_name . "->meta => (" . ($meta_type) . ")";
# NOTE:
# we also need to check that instance metaclasses
# are compatabile in the same the class.
($self->instance_metaclass->isa($meta->instance_metaclass))
- || confess $name . "->meta => (" . ($self->instance_metaclass) . ")" .
+ || confess $self->name . "->meta => (" . ($self->instance_metaclass) . ")" .
" is not compatible with the " .
$class_name . "->meta => (" . ($meta->instance_metaclass) . ")";
}
sub DESTROY {
my $self = shift;
no warnings 'uninitialized';
- my $name = $self->name;
- return unless $name =~ /^$ANON_CLASS_PREFIX/;
- my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/);
+ return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
+ my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
no strict 'refs';
foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) {
delete ${$ANON_CLASS_PREFIX . $serial_id}{$key};
# NOTE:
# this will only work for a HASH instance type
if ($class->is_anon_class) {
- (reftype($instance) eq 'HASH')
+ (Scalar::Util::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
return $instance;
}
+
sub get_meta_instance {
- my $class = shift;
- return $class->instance_metaclass->new(
- $class,
- $class->compute_all_applicable_attributes()
+ my $self = shift;
+ # NOTE:
+ # just about any fiddling with @ISA or
+ # any fiddling with attributes will
+ # also fiddle with the symbol table
+ # and therefore invalidate the package
+ # cache, in which case we should blow
+ # away the meta-instance cache. Of course
+ # this will invalidate it more often then
+ # is probably needed, but better safe
+ # then sorry.
+ # - SL
+ $self->{'$!_meta_instance'} = undef
+ if defined $self->{'$!_package_cache_flag'} &&
+ $self->{'$!_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->name);
+ $self->{'$!_meta_instance'} ||= $self->instance_metaclass->new(
+ $self,
+ $self->compute_all_applicable_attributes()
);
}
sub clone_object {
my $class = shift;
my $instance = shift;
-
- my $name = $class->name;
-
- (blessed($instance) && $instance->isa($name))
- || confess "You must pass an instance ($instance) of the metaclass (" . $name . ")";
+ (blessed($instance) && $instance->isa($class->name))
+ || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
# NOTE:
# we need to protect the integrity of the
# Class::MOP::Class singletons here, they
sub rebless_instance {
my ($self, $instance, %params) = @_;
-
my $old_metaclass;
if ($instance->can('meta')) {
($instance->meta->isa('Class::MOP::Class'))
}
my $meta_instance = $self->get_meta_instance();
- my $name = $self->name;
- my $old_name = $old_metaclass->name;
-
- $name->isa($old_name)
- || confess "You may rebless only into a subclass of (". $old_name ."), of which (". $name .") isn't.";
+
+ $self->name->isa($old_metaclass->name)
+ || confess "You may rebless only into a subclass of (". $old_metaclass->name ."), of which (". $self->name .") isn't.";
# rebless!
$meta_instance->rebless_instance_structure($instance, $self);
# Inheritance
sub superclasses {
- my $self = shift;
+ my $self = shift;
+ my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' };
if (@_) {
my @supers = @_;
- @{$self->get_package_symbol('@ISA')} = @supers;
+ @{$self->get_package_symbol($var_spec)} = @supers;
# NOTE:
# we need to check the metaclass
# compatibility here so that we can
# we don't know about
$self->check_metaclass_compatability();
}
- @{$self->get_package_symbol('@ISA')};
+ @{$self->get_package_symbol($var_spec)};
}
sub subclasses {
(defined $method_name && $method_name)
|| confess "You must define a method name";
- my $name = $self->name;
my $body;
if (blessed($method)) {
$body = $method->body;
- if ($method->package_name ne $name &&
+ if ($method->package_name ne $self->name &&
$method->name ne $method_name) {
warn "Hello there, got somethig for you."
. " Method says " . $method->package_name . " " . $method->name
- . " Class says " . $name . " " . $method_name;
+ . " Class says " . $self->name . " " . $method_name;
$method = $method->clone(
- package_name => $name,
+ package_name => $self->name,
name => $method_name
) if $method->can('clone');
}
}
else {
$body = $method;
- ('CODE' eq (reftype($body) || ''))
+ ('CODE' eq ref($body))
|| confess "Your code block must be a CODE reference";
$method = $self->method_metaclass->wrap(
$body => (
- package_name => $name,
+ package_name => $self->name,
name => $method_name
)
);
}
$self->get_method_map->{$method_name} = $method;
- my $full_method_name = ($name . '::' . $method_name);
- $self->add_package_symbol("&${method_name}" =>
+ my $full_method_name = ($self->name . '::' . $method_name);
+ $self->add_package_symbol(
+ { sigil => '&', type => 'CODE', name => $method_name },
Class::MOP::subname($full_method_name => $body)
);
$self->update_package_cache_flag;
|| confess "You must define a method name";
my $body = (blessed($method) ? $method->body : $method);
- ('CODE' eq (reftype($body) || ''))
+ ('CODE' eq ref($body))
|| confess "Your code block must be a CODE reference";
- $self->add_package_symbol("&${method_name}" => $body);
+ $self->add_package_symbol(
+ { sigil => '&', type => 'CODE', name => $method_name } => $body
+ );
$self->update_package_cache_flag;
}
my $removed_method = delete $self->get_method_map->{$method_name};
- $self->remove_package_symbol("&${method_name}");
+ $self->remove_package_symbol(
+ { sigil => '&', type => 'CODE', name => $method_name }
+ );
$self->update_package_cache_flag;
# name here so that we can properly detach
# the old attr object, and remove any
# accessors it would have generated
- my $attr_name = $attribute->name;
- $self->remove_attribute($attr_name)
- if $self->has_attribute($attr_name);
+ $self->remove_attribute($attribute->name)
+ if $self->has_attribute($attribute->name);
# then onto installing the new accessors
$attribute->install_accessors();
- $self->get_attribute_map->{$attr_name} = $attribute;
+ $self->get_attribute_map->{$attribute->name} = $attribute;
}
sub has_attribute {