use strict;
use warnings;
+use Class::MOP::Instance;
+use Class::MOP::Method::Wrapped;
+
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype', 'weaken';
use Sub::Name 'subname';
use B 'svref_2object';
-our $VERSION = '0.20';
+our $VERSION = '0.21';
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Module';
-use Class::MOP::Instance;
-
# Self-introspection
sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
my $package_name = shift;
(defined $package_name && $package_name && !blessed($package_name))
|| confess "You must pass a package name and it cannot be blessed";
- $class->construct_class_instance(':package' => $package_name, @_);
+ $class->construct_class_instance('package' => $package_name, @_);
}
sub reinitialize {
(defined $package_name && $package_name && !blessed($package_name))
|| confess "You must pass a package name and it cannot be blessed";
Class::MOP::remove_metaclass_by_name($package_name);
- $class->construct_class_instance(':package' => $package_name, @_);
+ $class->construct_class_instance('package' => $package_name, @_);
}
# NOTE: (meta-circularity)
sub construct_class_instance {
my $class = shift;
my %options = @_;
- my $package_name = $options{':package'};
+ my $package_name = $options{'package'};
(defined $package_name && $package_name)
|| confess "You must pass a package name";
# NOTE:
: blessed($class))
: $class);
- $class = blessed($class) || $class;
# now create the metaclass
my $meta;
if ($class =~ /^Class::MOP::Class$/) {
no strict 'refs';
$meta = bless {
# inherited from Class::MOP::Package
- '$:package' => $package_name,
+ '$!package' => $package_name,
# NOTE:
# since the following attributes will
# listed here for reference, because they
# should not actually have a value associated
# with the slot.
- '%:namespace' => \undef,
+ '%!namespace' => \undef,
# inherited from Class::MOP::Module
- '$:version' => \undef,
- '$:authority' => \undef,
+ '$!version' => \undef,
+ '$!authority' => \undef,
# defined in Class::MOP::Class
+ '@!superclasses' => \undef,
- '%:methods' => {},
- '%:attributes' => {},
- '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute',
- '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method',
- '$:instance_metaclass' => $options{':instance_metaclass'} || 'Class::MOP::Instance',
+ '%!methods' => {},
+ '%!attributes' => {},
+ '$!attribute_metaclass' => $options{'attribute_metaclass'} || 'Class::MOP::Attribute',
+ '$!method_metaclass' => $options{'method_metaclass'} || 'Class::MOP::Method',
+ '$!instance_metaclass' => $options{'instance_metaclass'} || 'Class::MOP::Instance',
} => $class;
}
else {
sub is_anon_class {
my $self = shift;
+ no warnings 'uninitialized';
$self->name =~ /^$ANON_CLASS_PREFIX/ ? 1 : 0;
}
# really need to be handled explicitly
sub DESTROY {
my $self = shift;
+ no warnings 'uninitialized';
return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
no strict 'refs';
# all these attribute readers will be bootstrapped
# away in the Class::MOP bootstrap section
-sub get_attribute_map { $_[0]->{'%:attributes'} }
-sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
-sub method_metaclass { $_[0]->{'$:method_metaclass'} }
-sub instance_metaclass { $_[0]->{'$:instance_metaclass'} }
+sub get_attribute_map { $_[0]->{'%!attributes'} }
+sub attribute_metaclass { $_[0]->{'$!attribute_metaclass'} }
+sub method_metaclass { $_[0]->{'$!method_metaclass'} }
+sub instance_metaclass { $_[0]->{'$!instance_metaclass'} }
# FIXME:
# this is a prime canidate for conversion to XS
sub get_method_map {
my $self = shift;
- my $map = $self->{'%:methods'};
+ my $map = $self->{'%!methods'};
my $class_name = $self->name;
my $method_metaclass = $self->method_metaclass;
foreach my $symbol ($self->list_all_package_symbols('CODE')) {
my $code = $self->get_package_symbol('&' . $symbol);
- next if exists $map->{$symbol} && $map->{$symbol}->body == $code;
+ next if exists $map->{$symbol} &&
+ defined $map->{$symbol} &&
+ $map->{$symbol}->body == $code;
my $gv = svref_2object($code)->GV;
next if ($gv->STASH->NAME || '') ne $class_name &&
(blessed($instance))
|| confess "You can only clone instances, \$self is not a blessed instance";
my $meta_instance = $class->get_meta_instance();
- my $clone = $meta_instance->clone_instance($instance);
- foreach my $key (keys %params) {
- next unless $meta_instance->is_valid_slot($key);
- $meta_instance->set_slot_value($clone, $key, $params{$key});
- }
+ my $clone = $meta_instance->clone_instance($instance);
+ foreach my $attr ($class->compute_all_applicable_attributes()) {
+ if ($params{$attr->init_arg}) {
+ $meta_instance->set_slot_value($clone, $attr->name, $params{$attr->init_arg});
+ }
+ }
return $clone;
}
$method = $self->find_next_method_by_name($method_name);
# die if it does not exist
(defined $method)
- || confess "The method '$method_name' is not found in the inherience hierarchy for this class";
+ || confess "The method '$method_name' is not found in the inherience hierarchy for class " . $self->name;
# and now make sure to wrap it
# even if it is already wrapped
# because we need a new sub ref
sub find_method_by_name {
my ($self, $method_name) = @_;
- # FIXME
- return $self->name->can($method_name);
+ (defined $method_name && $method_name)
+ || confess "You must define a method name to find";
+ # keep a record of what we have seen
+ # here, this will handle all the
+ # inheritence issues because we are
+ # using the &class_precedence_list
+ my %seen_class;
+ my @cpl = $self->class_precedence_list();
+ foreach my $class (@cpl) {
+ next if $seen_class{$class};
+ $seen_class{$class}++;
+ # fetch the meta-class ...
+ my $meta = $self->initialize($class);
+ return $meta->get_method($method_name)
+ if $meta->has_method($method_name);
+ }
+ return;
}
sub compute_all_applicable_methods {
sub is_mutable { 1 }
sub is_immutable { 0 }
-sub make_immutable {
- return Class::MOP::Class::Immutable->make_metaclass_immutable(@_);
+{
+ use Class::MOP::Immutable;
+
+ my $IMMUTABLE_META;
+
+ sub make_immutable {
+ my ($self) = @_;
+
+ $IMMUTABLE_META ||= Class::MOP::Immutable->new($self->meta, {
+ read_only => [qw/superclasses/],
+ cannot_call => [qw/
+ add_method
+ alias_method
+ remove_method
+ add_attribute
+ remove_attribute
+ add_package_symbol
+ remove_package_symbol
+ /],
+ memoize => {
+ class_precedence_list => 'ARRAY',
+ compute_all_applicable_attributes => 'ARRAY',
+ get_meta_instance => 'SCALAR',
+ get_method_map => 'SCALAR',
+ }
+ })->create_immutable_metaclass;
+
+ $IMMUTABLE_META->make_metaclass_immutable(@_);
+ }
}
1;