use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.75';
+our $VERSION = '0.77_01';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
bless {
# inherited from Class::MOP::Package
- 'package' => $options->{package},
+ 'package' => $options->{package},
# 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,
+ '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',
+ 'attribute_metaclass' => $options->{'attribute_metaclass'}
+ || 'Class::MOP::Attribute',
+ 'method_metaclass' => $options->{'method_metaclass'}
+ || 'Class::MOP::Method',
+ 'wrapped_method_metaclass' => $options->{'wrapped_method_metaclass'}
+ || 'Class::MOP::Method::Wrapped',
+ 'instance_metaclass' => $options->{'instance_metaclass'}
+ || 'Class::MOP::Instance',
}, $class;
}
my @class_list = $self->linearized_isa;
shift @class_list; # shift off $self->name
- foreach my $class_name (@class_list) {
- my $meta = Class::MOP::get_metaclass_by_name($class_name) || next;
+ foreach my $superclass_name (@class_list) {
+ my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || next;
# NOTE:
# we need to deal with the possibility
# of class immutability here, and then
# get the name of the class appropriately
- my $meta_type = ($meta->is_immutable
- ? $meta->get_mutable_metaclass_name()
- : ref($meta));
+ my $super_meta_type
+ = $super_meta->is_immutable
+ ? $super_meta->get_mutable_metaclass_name()
+ : ref($super_meta);
- ($self->isa($meta_type))
+ ($self->isa($super_meta_type))
|| confess $self->name . "->meta => (" . (ref($self)) . ")" .
" is not compatible with the " .
- $class_name . "->meta => (" . ($meta_type) . ")";
+ $superclass_name . "->meta => (" . ($super_meta_type) . ")";
# NOTE:
# we also need to check that instance metaclasses
# are compatibile in the same the class.
- ($self->instance_metaclass->isa($meta->instance_metaclass))
+ ($self->instance_metaclass->isa($super_meta->instance_metaclass))
|| confess $self->name . "->meta->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
" is not compatible with the " .
- $class_name . "->meta->instance_metaclass => (" . ($meta->instance_metaclass) . ")";
+ $superclass_name . "->meta->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")";
}
}
# 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_method_map {
- my $self = shift;
-
- my $class_name = $self->name;
-
- my $current = Class::MOP::check_package_cache_flag($class_name);
-
- if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
- return $self->{'methods'} ||= {};
- }
-
- $self->{_package_cache_flag} = $current;
-
- my $map = $self->{'methods'} ||= {};
-
- my $method_metaclass = $self->method_metaclass;
-
- my $all_code = $self->get_all_package_symbols('CODE');
-
- foreach my $symbol (keys %{ $all_code }) {
- my $code = $all_code->{$symbol};
-
- next if exists $map->{$symbol} &&
- defined $map->{$symbol} &&
- $map->{$symbol}->body == $code;
-
- my ($pkg, $name) = Class::MOP::get_code_info($code);
-
- # NOTE:
- # in 5.10 constant.pm the constants show up
- # as being in the right package, but in pre-5.10
- # they show up as constant::__ANON__ so we
- # make an exception here to be sure that things
- # work as expected in both.
- # - SL
- unless ($pkg eq 'constant' && $name eq '__ANON__') {
- next if ($pkg || '') ne $class_name ||
- (($name || '') ne '__ANON__' && ($pkg || '') ne $class_name);
- }
-
- $map->{$symbol} = $method_metaclass->wrap(
- $code,
- associated_metaclass => $self,
- package_name => $class_name,
- name => $symbol,
- );
- }
-
- return $map;
-}
+sub get_attribute_map { $_[0]->{'attributes'} }
+sub attribute_metaclass { $_[0]->{'attribute_metaclass'} }
+sub method_metaclass { $_[0]->{'method_metaclass'} }
+sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
+sub instance_metaclass { $_[0]->{'instance_metaclass'} }
# Instance Construction & Cloning
{
my $fetch_and_prepare_method = sub {
my ($self, $method_name) = @_;
+ my $wrapped_metaclass = $self->wrapped_method_metaclass;
# fetch it locally
my $method = $self->get_method($method_name);
# if we dont have local ...
$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 inheritance hierarchy for class " . $self->name;
+ || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name;
# and now make sure to wrap it
# even if it is already wrapped
# because we need a new sub ref
- $method = Class::MOP::Method::Wrapped->wrap($method);
+ $method = $wrapped_metaclass->wrap($method);
}
else {
# now make sure we wrap it properly
- $method = Class::MOP::Method::Wrapped->wrap($method)
- unless $method->isa('Class::MOP::Method::Wrapped');
+ $method = $wrapped_metaclass->wrap($method)
+ unless $method->isa($wrapped_metaclass);
}
$self->add_method($method_name => $method);
return $method;
(defined $method_name && $method_name)
|| confess "You must define a method name";
- # NOTE:
- # I don't really need this here, because
- # if the method_map is missing a key it
- # will just return undef for me now
- # return unless $self->has_method($method_name);
-
return $self->{methods}{$method_name} || $self->get_method_map->{$method_name};
}
} shift->get_all_methods(@_);
}
+sub get_all_method_names {
+ my $self = shift;
+ my %uniq;
+ grep { $uniq{$_}++ == 0 } map { $_->name } $self->get_all_methods;
+}
+
sub find_all_methods_by_name {
my ($self, $method_name) = @_;
(defined $method_name && $method_name)
class_precedence_list => 'ARRAY',
linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
get_all_methods => 'ARRAY',
+ get_all_method_names => 'ARRAY',
#get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future
compute_all_applicable_attributes => 'ARRAY',
get_meta_instance => 'SCALAR',
=item B<initialize ($package_name, %options)>
-This initializes and returns returns a B<Class::MOP::Class> object
-for a given a C<$package_name>.
+This initializes and returns returns a B<Class::MOP::Class> object for
+a given a C<$package_name>. If a metaclass already exists for the
+package, it simply returns it instead of creating a new one.
=item B<construct_class_instance (%options)>
=item B<get_method_map>
-Returns a HASH ref of name to CODE reference mapping for this class.
+Returns a HASH ref of name to L<Class::MOP::Method> instance mapping
+for this class.
=item B<method_metaclass>
=item B<find_method_by_name ($method_name)>
-This will return a CODE reference of the specified C<$method_name>,
-or return undef if that method does not exist.
+This will return a L<Class::MOP::Method> instance for the specified
+C<$method_name>, or return undef if that method does not exist.
Unlike C<get_method> this will also look in the superclasses.
=item B<remove_method ($method_name)>
This will attempt to remove a given C<$method_name> from the class.
-It will return the CODE reference that it has removed, and will
-attempt to use B<Sub::Name> to clear the methods associated name.
+It will return the L<Class::MOP::Method> instance that it has removed,
+and will attempt to use B<Sub::Name> to clear the methods associated
+name.
=item B<get_method_list>
=item B<get_all_methods>
-This will traverse the inheritance heirachy and return a list of all
+This will traverse the inheritance hierarchy and return a list of all
the applicable L<Class::MOP::Method> objects for this class.
=item B<compute_all_applicable_methods>
Use L<get_all_methods>, which is easier/better/faster. This method predates
L<Class::MOP::Method>.
+=item B<get_all_method_names>
+
+This will traverse the inheritance hierarchy and return a list of all the
+applicable method names for this class. Duplicate names are removed, but the
+order the methods come out is not defined.
+
=item B<find_all_methods_by_name ($method_name)>
This will traverse the inheritence hierarchy and locate all methods
=item B<get_all_attributes>
-This will traverse the inheritance heirachy and return a list of all
+This will traverse the inheritance hierarchy and return a list of all
the applicable L<Class::MOP::Attribute> objects for this class.
C<get_all_attributes> is an alias for consistency with C<get_all_methods>.
=item B<find_attribute_by_name ($attr_name)>
-This method will traverse the inheritance heirachy and find the
+This method will traverse the inheritance hierarchy and find the
first attribute whose name matches C<$attr_name>, then return it.
It will return undef if nothing is found.
projects / gitmo/Class-MOP.git / blobdiff