From: Hans Dieter Pearcey Date: Wed, 22 Jul 2009 23:02:54 +0000 (-0700) Subject: Merge branch 'master' into method_map_move X-Git-Tag: 0.92~22 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4eb970b276e026005c742fdafd37b83804f035a2;p=gitmo%2FClass-MOP.git Merge branch 'master' into method_map_move Conflicts: lib/Class/MOP/Class.pm t/010_self_introspection.t --- 4eb970b276e026005c742fdafd37b83804f035a2 diff --cc Changes index 4a072f1,31bee8c..9dc3e4e --- a/Changes +++ b/Changes @@@ -1,14 -1,33 +1,36 @@@ 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 diff --cc lib/Class/MOP/Class.pm index 1d57fa9,d073c2b..a1de0c8 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@@ -10,11 -10,11 +10,11 @@@ use Class::MOP::Method::Accessor use Class::MOP::Method::Constructor; use Carp 'confess'; - use Scalar::Util 'blessed', 'weaken'; + use Scalar::Util 'blessed', 'reftype', 'weaken'; -use Sub::Name 'subname'; +use Sub::Name 'subname'; use Devel::GlobalDestruction 'in_global_destruction'; - our $VERSION = '0.89'; + our $VERSION = '0.90'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; diff --cc lib/Class/MOP/Package.pm index 72ae745,36e3dbd..9a5fc73 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@@ -4,11 -4,10 +4,11 @@@ package Class::MOP::Package 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'; @@@ -91,9 -98,6 +99,11 @@@ sub namespace \%{$_[0]->{'package'} . '::'} } +sub method_metaclass { $_[0]->{'method_metaclass'} } +sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} } + ++sub _method_map { $_[0]->{'methods'} } ++ # utility methods { @@@ -278,97 -282,6 +288,129 @@@ sub list_all_package_symbols } } +## 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__ diff --cc t/010_self_introspection.t index 4ae3f09,04504f4..bcc6335 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@@ -34,11 -34,6 +34,13 @@@ my @class_mop_package_methods = qw add_package_symbol get_package_symbol has_package_symbol remove_package_symbol list_all_package_symbols get_all_package_symbols remove_package_glob + method_metaclass wrapped_method_metaclass + ++ _method_map ++ _code_is_mine + has_method get_method add_method remove_method wrap_method_body + get_method_list get_method_map + _deconstruct_variable_name );