Revision history for Perl extension Class-MOP.
- 0.90
+ 0.90 Tue Jul 21, 2009
+ Japan Perl Association has sponsored Goro Fuji to improve startup
+ performance of Class::MOP and Moose. These enhancements may break
+ backwards compatibility if you're doing (or using) complex
+ metaprogramming, so, as always, test your code!
+ http://blog.perlassociation.org/2009/07/jpa-sponsors-moose-class-mop-work.html
+
* Class::MOP::Class
* XS
- - Anonymous classes were not destroyed properly when they went
- out of scope, leading to a memory leak. RT #47480 (Goro Fuji).
+ - Anonymous classes were not completely destroyed when they went
+ out of scope, leading to a memory leak. RT #47480. (Goro
+ Fuji).
+
+ * Class::MOP::Class
+ - The get_method, has_method, and add_method methods no longer
+ use get_method_map. Method objects are instantiated
+ lazily. This significantly improves Class::MOP's load
+ time. (Goro Fuji)
+
+ * All classes
+ - Inline fewer metaclass-level constructors since the ones we
+ have are perfectly fine. This reduces the number of string
+ evals. (Goro Fuji)
+
+ * Class::MOP::Method::Wrapped
+ - If a method modifier set $_, this caused the modifier to blow
+ up, because of some weird internals. (Jeremy Stashewsky)
+ * Class::MOP::Class
+ * Class::MOP::Package
+ - Move get_method_map and its various scaffolding into Package. (hdp)
0.89 Fri Jul 3, 2009
* Class::MOP::Class
use strict;
use warnings;
- use Scalar::Util 'blessed';
+ use Scalar::Util 'blessed', 'reftype';
use Carp 'confess';
+use Sub::Name 'subname';
- our $VERSION = '0.89';
+ our $VERSION = '0.90';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
\%{$_[0]->{'package'} . '::'}
}
+sub method_metaclass { $_[0]->{'method_metaclass'} }
+sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
+
++sub _method_map { $_[0]->{'methods'} }
++
# utility methods
{
}
}
+## 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)
+ || confess "You must define a method name";
+
+ my $body;
+ if (blessed($method)) {
+ $body = $method->body;
+ if ($method->package_name ne $self->name) {
+ $method = $method->clone(
+ package_name => $self->name,
- name => $method_name
++ name => $method_name
+ ) if $method->can('clone');
+ }
++
++ $method->attach_to_class($self);
++ $self->_method_map->{$method_name} = $method;
+ }
+ else {
++ # If a raw code reference is supplied, its method object is not created.
++ # The method object won't be created until required.
+ $body = $method;
- $method = $self->wrap_method_body( body => $body, name => $method_name );
+ }
+
- $method->attach_to_class($self);
-
- $self->get_method_map->{$method_name} = $method;
+
+ my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
+
+ if ( !defined $current_name || $current_name eq '__ANON__' ) {
+ my $full_method_name = ($self->name . '::' . $method_name);
+ subname($full_method_name => $body);
+ }
+
+ $self->add_package_symbol(
+ { sigil => '&', type => 'CODE', name => $method_name },
+ $body,
+ );
+}
+
++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 {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
- exists $self->get_method_map->{$method_name};
++ return defined($self->get_method($method_name));
+}
+
+sub get_method {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
- return $self->get_method_map->{$method_name};
++ my $method_map = $self->_method_map;
++ my $method_object = $method_map->{$method_name};
++ my $code = $self->get_package_symbol({
++ name => $method_name,
++ sigil => '&',
++ type => 'CODE',
++ });
++
++ 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};
++ return undef;
++ }
++ }
++
++ return $method_object;
+}
+
+sub remove_method {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
+ my $removed_method = delete $self->get_method_map->{$method_name};
-
++
+ $self->remove_package_symbol(
+ { sigil => '&', type => 'CODE', name => $method_name }
+ );
+
+ $removed_method->detach_from_class if $removed_method;
+
+ $self->update_package_cache_flag; # still valid, since we just removed the method from the map
+
+ return $removed_method;
+}
+
+sub get_method_list {
+ my $self = shift;
- keys %{$self->get_method_map};
++ return grep { $self->has_method($_) } keys %{ $self->namespace };
+}
+
-
1;
__END__