From: Hans Dieter Pearcey Date: Sun, 12 Jul 2009 23:04:03 +0000 (-0400) Subject: move get_method_map into Package X-Git-Tag: 0.92~24 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b1ff395fc3ef6d0c559507cee9424803aa5f41c8;hp=dbea6de4246cb1d75716f20bf5863ca4e15671a1;p=gitmo%2FClass-MOP.git move get_method_map into Package --- diff --git a/Changes b/Changes index 4bba164..4a072f1 100644 --- a/Changes +++ b/Changes @@ -6,6 +6,9 @@ Revision history for Perl extension Class-MOP. - Anonymous classes were not destroyed properly when they went out of scope, leading to a memory leak. RT #47480 (Goro Fuji). + * 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 --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index e3c38ff..ee2f9a8 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -219,6 +219,42 @@ Class::MOP::Package->meta->add_attribute( )) ); +Class::MOP::Package->meta->add_attribute( + Class::MOP::Attribute->new('methods' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'get_method_map' => \&Class::MOP::Package::get_method_map + }, + default => sub { {} } + )) +); + +Class::MOP::Package->meta->add_attribute( + Class::MOP::Attribute->new('method_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'method_metaclass' => \&Class::MOP::Package::method_metaclass + }, + default => 'Class::MOP::Method', + )) +); + +Class::MOP::Package->meta->add_attribute( + Class::MOP::Attribute->new('wrapped_method_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'wrapped_method_metaclass' => \&Class::MOP::Package::wrapped_method_metaclass + }, + default => 'Class::MOP::Method::Wrapped', + )) +); + ## -------------------------------------------------------- ## Class::MOP::Module @@ -283,18 +319,6 @@ Class::MOP::Class->meta->add_attribute( ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('methods' => ( - reader => { - # NOTE: - # we just alias the original method - # rather than re-produce it here - 'get_method_map' => \&Class::MOP::Class::get_method_map - }, - default => sub { {} } - )) -); - -Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('superclasses' => ( accessor => { # NOTE: @@ -320,30 +344,6 @@ Class::MOP::Class->meta->add_attribute( ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('method_metaclass' => ( - reader => { - # NOTE: - # we just alias the original method - # rather than re-produce it here - 'method_metaclass' => \&Class::MOP::Class::method_metaclass - }, - default => 'Class::MOP::Method', - )) -); - -Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('wrapped_method_metaclass' => ( - reader => { - # NOTE: - # we just alias the original method - # rather than re-produce it here - 'wrapped_method_metaclass' => \&Class::MOP::Class::wrapped_method_metaclass - }, - default => 'Class::MOP::Method::Wrapped', - )) -); - -Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('instance_metaclass' => ( reader => { # NOTE: we need to do this in order diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index bb2385b..1d57fa9 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -11,7 +11,7 @@ use Class::MOP::Method::Constructor; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; -use Sub::Name 'subname'; +use Sub::Name 'subname'; use Devel::GlobalDestruction 'in_global_destruction'; our $VERSION = '0.89'; @@ -339,8 +339,6 @@ sub create { 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'} } sub immutable_trait { $_[0]->{'immutable_trait'} } sub constructor_class { $_[0]->{'constructor_class'} } @@ -590,55 +588,6 @@ sub class_precedence_list { ## 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 - ) if $method->can('clone'); - } - } - else { - $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, - ); -} - { my $fetch_and_prepare_method = sub { my ($self, $method_name) = @_; @@ -716,45 +665,6 @@ sub alias_method { shift->add_method(@_); } -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}; -} - -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}; -} - -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}; -} - sub find_method_by_name { my ($self, $method_name) = @_; (defined $method_name && $method_name) @@ -1508,50 +1418,14 @@ include indirect subclasses. =back -=head2 Method introspection and creation - -These methods allow you to introspect a class's methods, as well as -add, remove, or change methods. +=head2 Method introspection -Determining what is truly a method in a Perl 5 class requires some -heuristics (aka guessing). - -Methods defined outside the package with a fully qualified name (C) will be included. Similarly, methods named -with a fully qualified name using L are also included. - -However, we attempt to ignore imported functions. - -Ultimately, we are using heuristics to determine what truly is a -method in a class, and these heuristics may get the wrong answer in -some edge cases. However, for most "normal" cases the heuristics work -correctly. +See L for +methods that operate only on the current class. Class::MOP::Class adds +introspection capabilities that take inheritance into account. =over 4 -=item B<< $metaclass->get_method($method_name) >> - -This will return a L for the specified -C<$method_name>. If the class does not have the specified method, it -returns C - -=item B<< $metaclass->has_method($method_name) >> - -Returns a boolean indicating whether or not the class defines the -named method. It does not include methods inherited from parent -classes. - -=item B<< $metaclass->get_method_map >> - -Returns a hash reference representing the methods defined in this -class. The keys are method names and the values are -L objects. - -=item B<< $metaclass->get_method_list >> - -This will return a list of method I for all methods defined in -this class. - =item B<< $metaclass->get_all_methods >> This will traverse the inheritance hierarchy and return a list of all @@ -1589,38 +1463,6 @@ This method returns the first method in any superclass matching the given name. It is effectively the method that C would dispatch to. -=item B<< $metaclass->add_method($method_name, $method) >> - -This method takes a method name and a subroutine reference, and adds -the method to the class. - -The subroutine reference can be a L, and 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 directly. If not, the meta information will have to -be recreated later, and may be incorrect. - -If 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). - -=item B<< $metaclass->remove_method($method_name) >> - -Remove the named method from the class. This method returns the -L object for the method. - -=item B<< $metaclass->method_metaclass >> - -Returns the class name of the method metaclass, see -L for more information on the method metaclass. - -=item B<< $metaclass->wrapped_method_metaclass >> - -Returns the class name of the wrapped method metaclass, see -L for more information on the wrapped -method metaclass. - =back =head2 Attribute introspection and creation diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 0336a57..72ae745 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -6,6 +6,7 @@ use warnings; use Scalar::Util 'blessed'; use Carp 'confess'; +use Sub::Name 'subname'; our $VERSION = '0.89'; $VERSION = eval $VERSION; @@ -90,6 +91,9 @@ sub namespace { \%{$_[0]->{'package'} . '::'} } +sub method_metaclass { $_[0]->{'method_metaclass'} } +sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} } + # utility methods { @@ -274,6 +278,97 @@ 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 + ) if $method->can('clone'); + } + } + else { + $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 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}; +} + +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}; +} + +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}; +} + + 1; __END__ @@ -361,6 +456,84 @@ This works much like C, but it returns a hash reference. The keys are glob names and the values are references to the value for that name. +=back + +=head2 Method introspection and creation + +These methods allow you to introspect a class's methods, as well as +add, remove, or change methods. + +Determining what is truly a method in a Perl 5 class requires some +heuristics (aka guessing). + +Methods defined outside the package with a fully qualified name (C) will be included. Similarly, methods named +with a fully qualified name using L are also included. + +However, we attempt to ignore imported functions. + +Ultimately, we are using heuristics to determine what truly is a +method in a class, and these heuristics may get the wrong answer in +some edge cases. However, for most "normal" cases the heuristics work +correctly. + +=over 4 + +=item B<< $metapackage->get_method($method_name) >> + +This will return a L for the specified +C<$method_name>. If the class does not have the specified method, it +returns C + +=item B<< $metapackage->has_method($method_name) >> + +Returns a boolean indicating whether or not the class defines the +named method. It does not include methods inherited from parent +classes. + +=item B<< $metapackage->get_method_map >> + +Returns a hash reference representing the methods defined in this +class. The keys are method names and the values are +L objects. + +=item B<< $metapackage->get_method_list >> + +This will return a list of method I for all methods defined in +this class. + +=item B<< $metapackage->add_method($method_name, $method) >> + +This method takes a method name and a subroutine reference, and adds +the method to the class. + +The subroutine reference can be a L, and 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 directly. If not, the meta information will have to +be recreated later, and may be incorrect. + +If 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). + +=item B<< $metapackage->remove_method($method_name) >> + +Remove the named method from the class. This method returns the +L object for the method. + +=item B<< $metapackage->method_metaclass >> + +Returns the class name of the method metaclass, see +L for more information on the method metaclass. + +=item B<< $metapackage->wrapped_method_metaclass >> + +Returns the class name of the wrapped method metaclass, see +L for more information on the wrapped +method metaclass. + =item B<< Class::MOP::Package->meta >> This will return a L instance for this class. diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 5c870ce..4ae3f09 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -34,6 +34,11 @@ 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 + + has_method get_method add_method remove_method wrap_method_body + get_method_list get_method_map + _deconstruct_variable_name ); @@ -70,13 +75,12 @@ my @class_mop_class_methods = qw( add_dependent_meta_instance remove_dependent_meta_instance invalidate_meta_instances invalidate_meta_instance - attribute_metaclass method_metaclass wrapped_method_metaclass + attribute_metaclass superclasses subclasses direct_subclasses class_precedence_list linearized_isa _superclasses_updated - has_method get_method add_method remove_method alias_method wrap_method_body - get_method_list get_method_map get_all_method_names get_all_methods compute_all_applicable_methods + alias_method get_all_method_names get_all_methods compute_all_applicable_methods find_method_by_name find_all_methods_by_name find_next_method_by_name add_before_method_modifier add_after_method_modifier add_around_method_modifier @@ -155,6 +159,9 @@ foreach my $non_method_name (qw( my @class_mop_package_attributes = ( 'package', 'namespace', + 'methods', + 'method_metaclass', + 'wrapped_method_metaclass', ); my @class_mop_module_attributes = ( @@ -164,11 +171,8 @@ my @class_mop_module_attributes = ( my @class_mop_class_attributes = ( 'superclasses', - 'methods', 'attributes', 'attribute_metaclass', - 'method_metaclass', - 'wrapped_method_metaclass', 'instance_metaclass', 'immutable_trait', 'constructor_name', @@ -238,6 +242,37 @@ is(ref($class_mop_package_meta->get_attribute('package')->reader), 'HASH', '... ok($class_mop_package_meta->get_attribute('package')->has_init_arg, '... Class::MOP::Class package has a init_arg'); is($class_mop_package_meta->get_attribute('package')->init_arg, 'package', '... Class::MOP::Class package\'s a init_arg is package'); +ok($class_mop_package_meta->get_attribute('method_metaclass')->has_reader, '... Class::MOP::Package method_metaclass has a reader'); +is_deeply($class_mop_package_meta->get_attribute('method_metaclass')->reader, + { 'method_metaclass' => \&Class::MOP::Package::method_metaclass }, + '... Class::MOP::Package method_metaclass\'s a reader is &method_metaclass'); + +ok($class_mop_package_meta->get_attribute('method_metaclass')->has_init_arg, '... Class::MOP::Package method_metaclass has a init_arg'); +is($class_mop_package_meta->get_attribute('method_metaclass')->init_arg, + 'method_metaclass', + '... Class::MOP::Package method_metaclass\'s init_arg is method_metaclass'); + +ok($class_mop_package_meta->get_attribute('method_metaclass')->has_default, '... Class::MOP::Package method_metaclass has a default'); +is($class_mop_package_meta->get_attribute('method_metaclass')->default, + 'Class::MOP::Method', + '... Class::MOP::Package method_metaclass\'s a default is Class::MOP:::Method'); + +ok($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->has_reader, '... Class::MOP::Package wrapped_method_metaclass has a reader'); +is_deeply($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->reader, + { 'wrapped_method_metaclass' => \&Class::MOP::Package::wrapped_method_metaclass }, + '... Class::MOP::Package wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass'); + +ok($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Package wrapped_method_metaclass has a init_arg'); +is($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->init_arg, + 'wrapped_method_metaclass', + '... Class::MOP::Package wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass'); + +ok($class_mop_package_meta->get_attribute('method_metaclass')->has_default, '... Class::MOP::Package method_metaclass has a default'); +is($class_mop_package_meta->get_attribute('method_metaclass')->default, + 'Class::MOP::Method', + '... Class::MOP::Package method_metaclass\'s a default is Class::MOP:::Method'); + + # ... class ok($class_mop_class_meta->get_attribute('attributes')->has_reader, '... Class::MOP::Class attributes has a reader'); @@ -270,36 +305,6 @@ is($class_mop_class_meta->get_attribute('attribute_metaclass')->default, 'Class::MOP::Attribute', '... Class::MOP::Class attribute_metaclass\'s a default is Class::MOP:::Attribute'); -ok($class_mop_class_meta->get_attribute('method_metaclass')->has_reader, '... Class::MOP::Class method_metaclass has a reader'); -is_deeply($class_mop_class_meta->get_attribute('method_metaclass')->reader, - { 'method_metaclass' => \&Class::MOP::Class::method_metaclass }, - '... Class::MOP::Class method_metaclass\'s a reader is &method_metaclass'); - -ok($class_mop_class_meta->get_attribute('method_metaclass')->has_init_arg, '... Class::MOP::Class method_metaclass has a init_arg'); -is($class_mop_class_meta->get_attribute('method_metaclass')->init_arg, - 'method_metaclass', - '... Class::MOP::Class method_metaclass\'s init_arg is method_metaclass'); - -ok($class_mop_class_meta->get_attribute('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default'); -is($class_mop_class_meta->get_attribute('method_metaclass')->default, - 'Class::MOP::Method', - '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method'); - -ok($class_mop_class_meta->get_attribute('wrapped_method_metaclass')->has_reader, '... Class::MOP::Class wrapped_method_metaclass has a reader'); -is_deeply($class_mop_class_meta->get_attribute('wrapped_method_metaclass')->reader, - { 'wrapped_method_metaclass' => \&Class::MOP::Class::wrapped_method_metaclass }, - '... Class::MOP::Class wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass'); - -ok($class_mop_class_meta->get_attribute('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Class wrapped_method_metaclass has a init_arg'); -is($class_mop_class_meta->get_attribute('wrapped_method_metaclass')->init_arg, - 'wrapped_method_metaclass', - '... Class::MOP::Class wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass'); - -ok($class_mop_class_meta->get_attribute('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default'); -is($class_mop_class_meta->get_attribute('method_metaclass')->default, - 'Class::MOP::Method', - '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method'); - # check the values of some of the methods is($class_mop_class_meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name'); diff --git a/xs/Class.xs b/xs/Class.xs deleted file mode 100644 index e187b4d..0000000 --- a/xs/Class.xs +++ /dev/null @@ -1,116 +0,0 @@ -#include "mop.h" - -static void -mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map) -{ - const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */ - SV *method_metaclass_name; - char *method_name; - I32 method_name_len; - SV *coderef; - HV *symbols; - dSP; - - symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE); - sv_2mortal((SV*)symbols); - (void)hv_iterinit(symbols); - while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) { - CV *cv = (CV *)SvRV(coderef); - char *cvpkg_name; - char *cv_name; - SV *method_slot; - SV *method_object; - - if (!mop_get_code_info(coderef, &cvpkg_name, &cv_name)) { - continue; - } - - /* this checks to see that the subroutine is actually from our package */ - if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) { - if ( strNE(cvpkg_name, class_name_pv) ) { - continue; - } - } - - method_slot = *hv_fetch(map, method_name, method_name_len, TRUE); - if ( SvOK(method_slot) ) { - SV *const body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */ - if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) { - continue; - } - } - - method_metaclass_name = mop_call0(aTHX_ self, mop_method_metaclass); /* $self->method_metaclass() */ - - /* - $method_object = $method_metaclass->wrap( - $cv, - associated_metaclass => $self, - package_name => $class_name, - name => $method_name - ); - */ - ENTER; - SAVETMPS; - - PUSHMARK(SP); - EXTEND(SP, 8); - PUSHs(method_metaclass_name); /* invocant */ - mPUSHs(newRV_inc((SV *)cv)); - PUSHs(mop_associated_metaclass); - PUSHs(self); - PUSHs(KEY_FOR(package_name)); - PUSHs(class_name); - PUSHs(KEY_FOR(name)); - mPUSHs(newSVpv(method_name, method_name_len)); - PUTBACK; - - call_sv(mop_wrap, G_SCALAR | G_METHOD); - SPAGAIN; - method_object = POPs; - PUTBACK; - /* $map->{$method_name} = $method_object */ - sv_setsv(method_slot, method_object); - - FREETMPS; - LEAVE; - } -} - -MODULE = Class::MOP::Class PACKAGE = Class::MOP::Class - -PROTOTYPES: DISABLE - -void -get_method_map(self) - SV *self - PREINIT: - HV *const obj = (HV *)SvRV(self); - SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) ); - HV *const stash = gv_stashsv(class_name, 0); - UV current; - SV *cache_flag; - SV *map_ref; - PPCODE: - if (!stash) { - mXPUSHs(newRV_noinc((SV *)newHV())); - return; - } - - current = mop_check_package_cache_flag(aTHX_ stash); - cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag))); - map_ref = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods))); - - /* $self->{methods} does not yet exist (or got deleted) */ - if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) { - SV *new_map_ref = newRV_noinc((SV *)newHV()); - sv_2mortal(new_map_ref); - sv_setsv(map_ref, new_map_ref); - } - - if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) { - mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref)); - sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */ - } - - XPUSHs(map_ref); diff --git a/xs/MOP.xs b/xs/MOP.xs index 5dfc0cd..85c7659 100644 --- a/xs/MOP.xs +++ b/xs/MOP.xs @@ -16,7 +16,6 @@ find_method (const char *key, STRLEN keylen, SV *val, void *ud) } EXTERN_C XS(boot_Class__MOP__Package); -EXTERN_C XS(boot_Class__MOP__Class); EXTERN_C XS(boot_Class__MOP__Attribute); EXTERN_C XS(boot_Class__MOP__Method); @@ -32,7 +31,6 @@ BOOT: mop_associated_metaclass = newSVpvs("associated_metaclass"); MOP_CALL_BOOT (boot_Class__MOP__Package); - MOP_CALL_BOOT (boot_Class__MOP__Class); MOP_CALL_BOOT (boot_Class__MOP__Attribute); MOP_CALL_BOOT (boot_Class__MOP__Method); diff --git a/xs/Package.xs b/xs/Package.xs index ce8d390..362c407 100644 --- a/xs/Package.xs +++ b/xs/Package.xs @@ -1,5 +1,82 @@ #include "mop.h" +static void +mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map) +{ + const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */ + SV *method_metaclass_name; + char *method_name; + I32 method_name_len; + SV *coderef; + HV *symbols; + dSP; + + symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE); + sv_2mortal((SV*)symbols); + (void)hv_iterinit(symbols); + while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) { + CV *cv = (CV *)SvRV(coderef); + char *cvpkg_name; + char *cv_name; + SV *method_slot; + SV *method_object; + + if (!mop_get_code_info(coderef, &cvpkg_name, &cv_name)) { + continue; + } + + /* this checks to see that the subroutine is actually from our package */ + if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) { + if ( strNE(cvpkg_name, class_name_pv) ) { + continue; + } + } + + method_slot = *hv_fetch(map, method_name, method_name_len, TRUE); + if ( SvOK(method_slot) ) { + SV *const body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */ + if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) { + continue; + } + } + + method_metaclass_name = mop_call0(aTHX_ self, mop_method_metaclass); /* $self->method_metaclass() */ + + /* + $method_object = $method_metaclass->wrap( + $cv, + associated_metaclass => $self, + package_name => $class_name, + name => $method_name + ); + */ + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 8); + PUSHs(method_metaclass_name); /* invocant */ + mPUSHs(newRV_inc((SV *)cv)); + PUSHs(mop_associated_metaclass); + PUSHs(self); + PUSHs(KEY_FOR(package_name)); + PUSHs(class_name); + PUSHs(KEY_FOR(name)); + mPUSHs(newSVpv(method_name, method_name_len)); + PUTBACK; + + call_sv(mop_wrap, G_SCALAR | G_METHOD); + SPAGAIN; + method_object = POPs; + PUTBACK; + /* $map->{$method_name} = $method_object */ + sv_setsv(method_slot, method_object); + + FREETMPS; + LEAVE; + } +} + MODULE = Class::MOP::Package PACKAGE = Class::MOP::Package PROTOTYPES: DISABLE @@ -35,5 +112,39 @@ get_all_package_symbols(self, filter=TYPE_FILTER_NONE) symbols = mop_get_all_package_symbols(stash, filter); PUSHs(sv_2mortal(newRV_noinc((SV *)symbols))); +void +get_method_map(self) + SV *self + PREINIT: + HV *const obj = (HV *)SvRV(self); + SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) ); + HV *const stash = gv_stashsv(class_name, 0); + UV current; + SV *cache_flag; + SV *map_ref; + PPCODE: + if (!stash) { + mXPUSHs(newRV_noinc((SV *)newHV())); + return; + } + + current = mop_check_package_cache_flag(aTHX_ stash); + cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag))); + map_ref = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods))); + + /* $self->{methods} does not yet exist (or got deleted) */ + if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) { + SV *new_map_ref = newRV_noinc((SV *)newHV()); + sv_2mortal(new_map_ref); + sv_setsv(map_ref, new_map_ref); + } + + if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) { + mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref)); + sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */ + } + + XPUSHs(map_ref); + BOOT: INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);