use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.64_04';
+our $VERSION = '0.77';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
}
# and check the metaclass compatibility
- $meta->check_metaclass_compatability();
+ $meta->check_metaclass_compatibility();
Class::MOP::store_metaclass_by_name($package_name, $meta);
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;
}
$self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
}
-sub check_metaclass_compatability {
+sub check_metaclass_compatibility {
my $self = shift;
# this is always okay ...
$class_name . "->meta => (" . ($meta_type) . ")";
# NOTE:
# we also need to check that instance metaclasses
- # are compatabile in the same the class.
+ # are compatibile in the same the class.
($self->instance_metaclass->isa($meta->instance_metaclass))
- || confess $self->name . "->meta => (" . ($self->instance_metaclass) . ")" .
+ || confess $self->name . "->meta->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
" is not compatible with the " .
- $class_name . "->meta => (" . ($meta->instance_metaclass) . ")";
+ $class_name . "->meta->instance_metaclass => (" . ($meta->instance_metaclass) . ")";
}
}
+# backwards compat for stevan's inability to spell ;)
+sub check_metaclass_compatability {
+ my $self = shift;
+ $self->check_metaclass_compatibility(@_);
+}
+
## ANON classes
{
sub DESTROY {
my $self = shift;
- return if Class::MOP::in_global_destruction; # it'll happen soon anyway and this just makes things more complicated
+ return if Class::MOP::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/;
+ # 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);
+ return if $current_meta ne $self;
+
my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
no strict 'refs';
foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) {
my (%options) = @args;
my $package_name = $options{package};
- (defined $package_name && $package_name)
- || confess "You must pass a package name";
-
(ref $options{superclasses} eq 'ARRAY')
|| confess "You must pass an ARRAY ref of superclasses"
if exists $options{superclasses};
if exists $options{attributes};
(ref $options{methods} eq 'HASH')
- || confess "You must pass an HASH ref of methods"
+ || confess "You must pass a HASH ref of methods"
if exists $options{methods};
- my $code = "package $package_name;";
- $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';"
- if exists $options{version};
- $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';"
- if exists $options{authority};
+ $class->SUPER::create(%options);
- eval $code;
- confess "creation of $package_name failed : $@" if $@;
-
- my $meta = $class->initialize($package_name);
+ my (%initialize_options) = @args;
+ delete @initialize_options{qw(
+ package
+ superclasses
+ attributes
+ methods
+ version
+ authority
+ )};
+ my $meta = $class->initialize( $package_name => %initialize_options );
# FIXME totally lame
$meta->add_method('meta' => sub {
# 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 wrapped_method_metaclass { $_[0]->{'wrapped_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 $current = Class::MOP::check_package_cache_flag($self->name);
+
+ 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 $map = $self->{'methods'} ||= {};
- my $class_name = $self->name;
my $method_metaclass = $self->method_metaclass;
- my %all_code = $self->get_all_package_symbols('CODE');
+ my $all_code = $self->get_all_package_symbols('CODE');
- foreach my $symbol (keys %all_code) {
- my $code = $all_code{$symbol};
+ foreach my $symbol (keys %{ $all_code }) {
+ my $code = $all_code->{$symbol};
next if exists $map->{$symbol} &&
defined $map->{$symbol} &&
if (@_) {
my @supers = @_;
@{$self->get_package_symbol($var_spec)} = @supers;
+
+ # NOTE:
+ # on 5.8 and below, we need to call
+ # a method to get Perl to detect
+ # a cycle in the class hierarchy
+ my $class = $self->name;
+ $class->isa($class);
+
# NOTE:
# we need to check the metaclass
# compatibility here so that we can
# be sure that the superclass is
# not potentially creating an issues
# we don't know about
- $self->check_metaclass_compatability();
+
+ $self->check_metaclass_compatibility();
$self->update_meta_instance_dependencies();
}
@{$self->get_package_symbol($var_spec)};
sub wrap_method_body {
my ( $self, %args ) = @_;
- my $body = delete $args{body}; # delete is for compat
-
- ('CODE' eq ref($body))
+ ('CODE' eq ref $args{body})
|| confess "Your code block must be a CODE reference";
- $self->method_metaclass->wrap( $body => (
+ $self->method_metaclass->wrap(
package_name => $self->name,
%args,
- ));
+ );
}
sub add_method {
my $body;
if (blessed($method)) {
$body = $method->body;
- if ($method->package_name ne $self->name &&
- $method->name ne $method_name) {
- warn "Hello there, got something for you."
- . " Method says " . $method->package_name . " " . $method->name
- . " Class says " . $self->name . " " . $method_name;
+ if ($method->package_name ne $self->name) {
$method = $method->clone(
package_name => $self->name,
name => $method_name
$method->attach_to_class($self);
- $self->get_method_map->{$method_name} = $method;
+ # This used to call get_method_map, which meant we would build all
+ # the method objects for the class just because we added one
+ # method. This is hackier, but quicker too.
+ $self->{methods}{$method_name} = $method;
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; # still valid, since we just added the method to the map, and if it was invalid before that then get_method_map updated it
}
{
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 ...
# 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;
}
sub alias_method {
- my ($self, $method_name, $method) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- my $body = (blessed($method) ? $method->body : $method);
- ('CODE' eq ref($body))
- || confess "Your code block must be a CODE reference";
-
- $self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name } => $body
- );
+ my $self = shift;
- $self->update_package_cache_flag; # the method map will not list aliased methods
+ $self->add_method(@_);
}
sub has_method {
(defined $method_name && $method_name)
|| confess "You must define a method name";
- exists $self->get_method_map->{$method_name};
+ exists $self->{methods}{$method_name} || exists $self->get_method_map->{$method_name};
}
sub get_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->get_method_map->{$method_name};
+ return $self->{methods}{$method_name} || $self->get_method_map->{$method_name};
}
sub remove_method {
} 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)
sub get_immutable_transformer {
my $self = shift;
if( $self->is_mutable ){
- my $class = ref $self || $self;
- return $IMMUTABLE_TRANSFORMERS{$class} ||= $self->create_immutable_transformer;
+ return $IMMUTABLE_TRANSFORMERS{$self->name} ||= $self->create_immutable_transformer;
}
confess "unable to find transformer for immutable class"
unless exists $IMMUTABLE_OPTIONS{$self->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',
best way to understand what this module can do, is to read the
documentation for each of it's methods.
+=head1 INHERITANCE
+
+B<Class::MOP::Class> is a subclass of L<Class::MOP::Module>
+
=head1 METHODS
=head2 Self Introspection
=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)>
method is used internally by C<initialize> and should never be called
from outside of that method really.
-=item B<check_metaclass_compatability>
+=item B<check_metaclass_compatibility>
This method is called as the very last thing in the
C<construct_class_instance> method. This will check that the
C<bless>-ing into your package of choice. It works in conjunction
with the Attribute protocol to collect all applicable attributes.
-This will construct and instance using a HASH ref as storage
+This will construct an instance using a HASH ref as storage
(currently only HASH references are supported). This will collect all
the applicable attributes and layout out the fields in the HASH ref,
it will then initialize them using either use the corresponding key
=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>
Wrap a code ref (C<$attrs{body>) with C<method_metaclass>.
-=item B<add_method ($method_name, $method, %attrs)>
+=item B<add_method ($method_name, $method)>
+
+This will take a C<$method_name> and CODE reference or meta method
+objectand install it into the class's package.
+
+You are strongly encouraged to pass a meta method object instead of a
+code reference. If you do so, that object gets stored as part of the
+class's method map, providing more useful information about the method
+for introspection.
-This will take a C<$method_name> and CODE reference to that
-C<$method> and install it into the class's package.
+When you provide a method object, this method will clone that object
+if the object's package name does not match the class name. This lets
+us track the original source of any methods added from other classes
+(notably Moose roles).
B<NOTE>:
This does absolutely nothing special to C<$method>
correct name, and therefore show up correctly in stack traces and
such.
-=item B<alias_method ($method_name, $method)>
-
-This will take a C<$method_name> and CODE reference to that
-C<$method> and alias the method into the class's package.
-
-B<NOTE>:
-Unlike C<add_method>, this will B<not> try to name the
-C<$method> using B<Sub::Name>, it only aliases the method in
-the class's package.
-
=item B<has_method ($method_name)>
This just provides a simple way to check if the class implements
=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>
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 heirachy 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
the superclasses, this is basically equivalent to calling
C<SUPER::$method_name>, but it can be dispatched at runtime.
+=item B<alias_method ($method_name, $method)>
+
+B<NOTE>: This method is now deprecated. Just use C<add_method>
+instead.
+
=back
=head2 Method Modifiers
around 2
around 1
primary
- after 1
- after 2
+ around 1
+ around 2
+ after 1
+ after 2
To see examples of using method modifiers, see the following examples
included in the distribution; F<InstanceCountingClass>, F<Perl6Attribute>,
projects / gitmo/Class-MOP.git / blobdiff