use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.65';
+our $VERSION = '0.71_02';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Module';
|| $class->construct_class_instance(package => $package_name, @_);
}
-sub reinitialize {
- my $class = shift;
- 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::MOP::remove_metaclass_by_name($package_name);
- $class->construct_class_instance('package' => $package_name, @_);
-}
-
# NOTE: (meta-circularity)
# this is a special form of &construct_instance
# (see below), which is used to construct class
}
# and check the metaclass compatibility
- $meta->check_metaclass_compatability();
+ $meta->check_metaclass_compatibility();
Class::MOP::store_metaclass_by_name($package_name, $meta);
$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 {
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 $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)};
## Methods
+sub wrap_method_body {
+ my ( $self, %args ) = @_;
+
+ ('CODE' eq ref $args{body})
+ || confess "Your code block must be a CODE reference";
+
+ $self->method_metaclass->wrap(
+ package_name => $self->name,
+ %args,
+ );
+}
+
sub add_method {
my ($self, $method_name, $method) = @_;
(defined $method_name && $method_name)
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
}
else {
$body = $method;
- ('CODE' eq ref($body))
- || confess "Your code block must be a CODE reference";
- $method = $self->method_metaclass->wrap(
- $body => (
- package_name => $self->name,
- name => $method_name
- )
- );
+ $method = $self->wrap_method_body( body => $body, 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
}
{
}
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";
+ my $self = shift;
- $self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name } => $body
- );
+ $self->add_method(@_);
}
sub has_method {
(defined $method_name && $method_name)
|| confess "You must define a method name";
- return 0 unless exists $self->get_method_map->{$method_name};
- return 1;
+ exists $self->{methods}{$method_name} || exists $self->get_method_map->{$method_name};
}
sub get_method {
# 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 {
return;
}
+# check if we can reinitialize
+sub is_pristine {
+ my $self = shift;
+
+ # if any local attr is defined
+ return if $self->get_attribute_list;
+
+ # or any non-declared methods
+ if ( my @methods = values %{ $self->get_method_map } ) {
+ my $metaclass = $self->method_metaclass;
+ foreach my $method ( @methods ) {
+ return if $method->isa("Class::MOP::Method::Generated");
+ # FIXME do we need to enforce this too? return unless $method->isa($metaclass);
+ }
+ }
+
+ return 1;
+}
+
## Class closing
sub is_mutable { 1 }
/],
memoize => {
class_precedence_list => 'ARRAY',
- linearized_isa => 'ARRAY',
+ linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
+ get_all_methods => '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',
get_method_map => 'SCALAR',
my $original = shift;
confess "Cannot add package symbols to an immutable metaclass"
unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
- goto $original->body;
+
+ # This is a workaround for a bug in 5.8.1 which thinks that
+ # goto $original->body
+ # is trying to go to a label
+ my $body = $original->body;
+ goto $body;
},
},
});
This initializes and returns returns a B<Class::MOP::Class> object
for a given a C<$package_name>.
-=item B<reinitialize ($package_name, %options)>
-
-This removes the old metaclass, and creates a new one in it's place.
-Do B<not> use this unless you really know what you are doing, it could
-very easily make a very large mess of your program.
-
=item B<construct_class_instance (%options)>
This will construct an instance of B<Class::MOP::Class>, it is
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
This returns true if the class has been made immutable.
+=item B<is_pristine>
+
+Checks whether the class has any data that will be lost if C<reinitialize> is
+called.
+
=back
=head2 Inheritance Relationships
Returns the class name of the method metaclass, see L<Class::MOP::Method>
for more information on the method metaclasses.
+=item B<wrap_method_body(%attrs)>
+
+Wrap a code ref (C<$attrs{body>) with C<method_metaclass>.
+
=item B<add_method ($method_name, $method)>
-This will take a C<$method_name> and CODE reference to that
-C<$method> and install it into the class's package.
+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.
+
+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
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
projects / gitmo/Class-MOP.git / blobdiff