use Class::MOP::Method::Constructor;
use Carp 'confess';
-use Scalar::Util 'blessed', 'weaken';
+use Scalar::Util 'blessed', 'reftype', 'weaken';
use Sub::Name 'subname';
use Devel::GlobalDestruction 'in_global_destruction';
-our $VERSION = '0.89';
+our $VERSION = '0.90';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
$package_name = $options{package};
}
- (defined $package_name && $package_name && !ref($package_name))
+ ($package_name && !ref($package_name))
|| confess "You must pass a package name and it cannot be blessed";
return Class::MOP::get_metaclass_by_name($package_name)
sub _new {
my $class = shift;
+
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
my $options = @_ == 1 ? $_[0] : {@_};
- bless {
+ return bless {
# inherited from Class::MOP::Package
'package' => $options->{package},
sub is_anon_class {
my $self = shift;
no warnings 'uninitialized';
- $self->name =~ /^$ANON_CLASS_PREFIX/;
+ $self->name =~ /^$ANON_CLASS_PREFIX/o;
}
sub create_anon_class {
no warnings 'uninitialized';
my $name = $self->name;
- return unless $name =~ /^$ANON_CLASS_PREFIX/;
+ return unless $name =~ /^$ANON_CLASS_PREFIX/o;
# 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
my $current_meta = Class::MOP::get_metaclass_by_name($name);
return if $current_meta ne $self;
- my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/);
+ my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o);
no strict 'refs';
@{$name . '::ISA'} = ();
%{$name . '::'} = ();
# NOTE:
# this will only work for a HASH instance type
if ($class->is_anon_class) {
- (Scalar::Util::reftype($instance) eq 'HASH')
+ (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
# and now make sure to wrap it
# even if it is already wrapped
# because we need a new sub ref
- $method = $wrapped_metaclass->wrap($method);
+ $method = $wrapped_metaclass->wrap($method,
+ package_name => $self->name,
+ name => $method_name,
+ );
}
else {
# now make sure we wrap it properly
- $method = $wrapped_metaclass->wrap($method)
- unless $method->isa($wrapped_metaclass);
+ $method = $wrapped_metaclass->wrap($method,
+ package_name => $self->name,
+ name => $method_name,
+ ) unless $method->isa($wrapped_metaclass);
}
$self->add_method($method_name => $method);
return $method;
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 _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 {
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,
- );
+ unless ( $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};
(defined $method_name && $method_name)
|| confess "You must define a method name to find";
foreach my $class ($self->linearized_isa) {
- # fetch the meta-class ...
- my $meta = $self->initialize($class);
- return $meta->get_method($method_name)
- if $meta->has_method($method_name);
+ my $method = $self->initialize($class)->get_method($method_name);
+ return $method if defined $method;
}
return;
}
sub get_all_method_names {
my $self = shift;
my %uniq;
- grep { $uniq{$_}++ == 0 } map { $_->name } $self->get_all_methods;
+ return grep { !$uniq{$_}++ } map { $self->initialize($_)->get_method_list } $self->linearized_isa;
}
sub find_all_methods_by_name {
my @cpl = $self->linearized_isa;
shift @cpl; # discard ourselves
foreach my $class (@cpl) {
- # fetch the meta-class ...
- my $meta = $self->initialize($class);
- return $meta->get_method($method_name)
- if $meta->has_method($method_name);
+ my $method = $self->initialize($class)->get_method($method_name);
+ return $method if defined $method;
}
return;
}
my $trait = $args{immutable_trait} = $self->immutable_trait
|| confess "no immutable trait specified for $self";
- my $meta_attr = $self->meta->find_attribute_by_name("immutable_trait");
+ my $meta = $self->meta;
+ my $meta_attr = $meta->find_attribute_by_name("immutable_trait");
my $class_name;
# 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;
+ = $meta->is_immutable
+ ? $meta->get_mutable_metaclass_name
+ : ref $meta;
- my $meta = $meta_name->create(
+ my $immutable_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 );
+ my $meth_name = $meth->name;
- if ( $meta->find_method_by_name( $meth->name ) ) {
- $meta->add_around_method_modifier( $meth->name, $meth->body );
+ if ( $immutable_meta->find_method_by_name( $meth_name ) ) {
+ $immutable_meta->add_around_method_modifier( $meth_name, $meth->body );
}
else {
- $meta->add_method( $meth->name, $meth->clone );
+ $immutable_meta->add_method( $meth_name, $meth->clone );
}
}
- $meta->make_immutable( inline_constructor => 0 );
+ $immutable_meta->make_immutable(
+ inline_constructor => 0,
+ inline_accessors => 0,
+ );
return $class_name;
}