use Carp 'confess';
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.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
my $current_meta = Class::MOP::get_metaclass_by_name($name);
return if $current_meta ne $self;
+ if(my $isa_ref = $self->get_package_symbol('@ISA')){
+ @{$isa_ref} = ();
+ }
+
+ %{ $self->namespace } = ();
+
my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o);
- no strict 'refs';
- @{$name . '::ISA'} = ();
- %{$name . '::'} = ();
- delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
Class::MOP::remove_metaclass_by_name($name);
+
+ no strict 'refs';
+ delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
+ return;
}
}
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'} }
sub constructor_name { $_[0]->{'constructor_name'} }
sub destructor_class { $_[0]->{'destructor_class'} }
- sub _method_map { $_[0]->{'methods'} }
-
# Instance Construction & Cloning
sub new_object {
sub superclasses {
my $self = shift;
- my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' };
if (@_) {
my @supers = @_;
- @{$self->get_package_symbol($var_spec)} = @supers;
+ @{$self->get_package_symbol('@ISA', create => 1)} = @supers;
# NOTE:
# on 5.8 and below, we need to call
$self->_check_metaclass_compatibility();
$self->_superclasses_updated();
}
- @{$self->get_package_symbol($var_spec)};
+ @{$self->get_package_symbol('@ISA', create => 1)};
}
sub _superclasses_updated {
## 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');
- }
-
- $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;
- }
-
- $self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name },
- $body,
- );
- }
-
{
my $fetch_and_prepare_method = sub {
my ($self, $method_name) = @_;
shift->add_method(@_);
}
- 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";
-
- 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";
-
- 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;
- return grep { $self->has_method($_) } keys %{ $self->namespace };
- }
-
sub find_method_by_name {
my ($self, $method_name) = @_;
(defined $method_name && $method_name)
sub has_attribute {
my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
+ (defined $attribute_name)
|| confess "You must define an attribute name";
exists $self->get_attribute_map->{$attribute_name};
}
sub get_attribute {
my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
+ (defined $attribute_name)
|| confess "You must define an attribute name";
return $self->get_attribute_map->{$attribute_name}
# NOTE:
sub remove_attribute {
my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
+ (defined $attribute_name)
|| confess "You must define an attribute name";
my $removed_attribute = $self->get_attribute_map->{$attribute_name};
return unless defined $removed_attribute;
=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<sub
- Package::name { ... }>) will be included. Similarly, methods named
- with a fully qualified name using L<Sub::Name> 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<Class::MOP::Package/Method introspection and creation> 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<Class::MOP::Method> for the specified
- C<$method_name>. If the class does not have the specified method, it
- returns C<undef>
-
- =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<Class::MOP::Method> objects.
-
- =item B<< $metaclass->get_method_list >>
-
- This will return a list of method I<names> 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
given name. It is effectively the method that C<SUPER::$method_name>
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<Class::MOP::Method>, 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<Class::MOP::Method> object for the method.
-
- =item B<< $metaclass->method_metaclass >>
-
- Returns the class name of the method metaclass, see
- L<Class::MOP::Method> for more information on the method metaclass.
-
- =item B<< $metaclass->wrapped_method_metaclass >>
-
- Returns the class name of the wrapped method metaclass, see
- L<Class::MOP::Method::Wrapped> for more information on the wrapped
- method metaclass.
-
=back
=head2 Attribute introspection and creation
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
- our $VERSION = '0.89';
+ our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
sub add_attribute { _immutable_cannot_call() }
sub remove_attribute { _immutable_cannot_call() }
sub remove_package_symbol { _immutable_cannot_call() }
+sub add_package_symbol { _immutable_cannot_call() }
sub class_precedence_list {
my $orig = shift;
$self->{__immutable}{get_method_map} ||= $self->$orig;
}
-sub add_package_symbol {
- my $orig = shift;
- my $self = shift;
- confess "Cannot add package symbols to an immutable metaclass"
- unless ( caller(3) )[3] eq 'Class::MOP::Package::get_package_symbol';
-
- $self->$orig(@_);
-}
-
1;
__END__
use Carp 'confess';
use Scalar::Util 'blessed';
- our $VERSION = '0.89';
+ our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
sub version {
my $self = shift;
- ${$self->get_package_symbol({ sigil => '$', type => 'SCALAR', name => 'VERSION' })};
+ ${$self->get_package_symbol('$VERSION', create => 1)};
}
sub authority {
my $self = shift;
- ${$self->get_package_symbol({ sigil => '$', type => 'SCALAR', name => 'AUTHORITY' })};
+ ${$self->get_package_symbol('$AUTHORITY', create => 1)};
}
sub identifier {
Class::MOP::_is_valid_class_name($package_name)
|| confess "creation of $package_name failed: invalid package name";
- no strict 'refs';
- scalar %{ $package_name . '::' }; # touch the stash
- ${ $package_name . '::VERSION' } = $version if defined $version;
- ${ $package_name . '::AUTHORITY' } = $authority if defined $authority;
+ $self->add_package_symbol('$VERSION', \$version);
+ $self->add_package_symbol('$AUTHORITY', \$authority);
return;
}
use Scalar::Util 'blessed', 'reftype';
use Carp 'confess';
+ use Sub::Name 'subname';
- our $VERSION = '0.89';
+ our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
my %options = @args;
my $package_name = delete $options{package};
- (defined $package_name && $package_name && !blessed($package_name))
- || confess "You must pass a package name and it cannot be blessed";
+ (defined $package_name && $package_name
+ && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
+ || confess "You must pass a package name or an existing Class::MOP::Package instance";
+
+ $package_name = $package_name->name
+ if blessed $package_name;
Class::MOP::remove_metaclass_by_name($package_name);
# we could just store a ref and it would
# Just Work, but oh well :\
no strict 'refs';
+ no warnings 'uninitialized';
\%{$_[0]->{'package'} . '::'}
}
+ sub method_metaclass { $_[0]->{'method_metaclass'} }
+ sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
+
+ sub _method_map { $_[0]->{'methods'} }
+
# utility methods
{
# ... these functions have to touch the symbol table itself,.. yuk
-sub add_package_symbol {
- my ($self, $variable, $initial_value) = @_;
-
- my ($name, $sigil, $type) = ref $variable eq 'HASH'
- ? @{$variable}{qw[name sigil type]}
- : $self->_deconstruct_variable_name($variable);
-
- my $pkg = $self->{'package'};
-
- no strict 'refs';
- no warnings 'redefine', 'misc', 'prototype';
- *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
-}
-
sub remove_package_glob {
my ($self, $name) = @_;
- no strict 'refs';
- delete ${$self->name . '::'}{$name};
-}
-
-# ... these functions deal with stuff on the namespace level
-
-sub has_package_symbol {
- my ( $self, $variable ) = @_;
-
- my ( $name, $sigil, $type )
- = ref $variable eq 'HASH'
- ? @{$variable}{qw[name sigil type]}
- : $self->_deconstruct_variable_name($variable);
-
- my $namespace = $self->namespace;
-
- return 0 unless exists $namespace->{$name};
-
- my $entry_ref = \$namespace->{$name};
- if ( reftype($entry_ref) eq 'GLOB' ) {
- if ( $type eq 'SCALAR' ) {
- return defined( ${ *{$entry_ref}{SCALAR} } );
- }
- else {
- return defined( *{$entry_ref}{$type} );
- }
- }
- else {
-
- # a symbol table entry can be -1 (stub), string (stub with prototype),
- # or reference (constant)
- return $type eq 'CODE';
- }
-}
-
-sub get_package_symbol {
- my ($self, $variable) = @_;
-
- my ($name, $sigil, $type) = ref $variable eq 'HASH'
- ? @{$variable}{qw[name sigil type]}
- : $self->_deconstruct_variable_name($variable);
-
- my $namespace = $self->namespace;
-
- # FIXME
- $self->add_package_symbol($variable)
- unless exists $namespace->{$name};
-
- my $entry_ref = \$namespace->{$name};
-
- if ( ref($entry_ref) eq 'GLOB' ) {
- return *{$entry_ref}{$type};
- }
- else {
- if ( $type eq 'CODE' ) {
- no strict 'refs';
- return \&{ $self->name . '::' . $name };
- }
- else {
- return undef;
- }
- }
+ delete $self->namespace->{$name};
}
sub remove_package_symbol {
}
}
+ ## 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');
+ }
+
+ $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;
+ }
+
+
+ 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";
+
+ 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";
+
+ 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;
+ return grep { $self->has_method($_) } keys %{ $self->namespace };
+ }
+
1;
__END__
represents specified package. If an existing metaclass object exists
for the package, that will be returned instead.
- =item B<< Class::MOP::Package->reinitialize($package_name) >>
+ =item B<< Class::MOP::Package->reinitialize($package) >>
This method forcibly removes any existing metaclass for the package
- before calling C<initialize>
+ before calling C<initialize>. In contrast to C<initialize>, you may
+ also pass an existing C<Class::MOP::Package> instance instead of just
+ a package name as C<$package>.
Do not call this unless you know what you are doing.
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<sub
+ Package::name { ... }>) will be included. Similarly, methods named
+ with a fully qualified name using L<Sub::Name> 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<Class::MOP::Method> for the specified
+ C<$method_name>. If the class does not have the specified method, it
+ returns C<undef>
+
+ =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<Class::MOP::Method> objects.
+
+ =item B<< $metapackage->get_method_list >>
+
+ This will return a list of method I<names> 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<Class::MOP::Method>, 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<Class::MOP::Method> object for the method.
+
+ =item B<< $metapackage->method_metaclass >>
+
+ Returns the class name of the method metaclass, see
+ L<Class::MOP::Method> for more information on the method metaclass.
+
+ =item B<< $metapackage->wrapped_method_metaclass >>
+
+ Returns the class name of the wrapped method metaclass, see
+ L<Class::MOP::Method::Wrapped> for more information on the wrapped
+ method metaclass.
+
=item B<< Class::MOP::Package->meta >>
This will return a L<Class::MOP::Class> instance for this class.
SV *mop_method_metaclass;
SV *mop_associated_metaclass;
SV *mop_wrap;
+SV *mop_namespace;
static bool
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);
mop_method_metaclass = newSVpvs("method_metaclass");
mop_wrap = newSVpvs("wrap");
mop_associated_metaclass = newSVpvs("associated_metaclass");
+ mop_namespace = newSVpvs("namespace");
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);
+
#include "mop.h"
-
static void
+mop_deconstruct_variable_name(pTHX_ SV* const variable,
+ const char** const var_name, STRLEN* const var_name_len,
+ svtype* const type,
+ const char** const type_name) {
+
+
+ if(SvROK(variable) && SvTYPE(SvRV(variable)) == SVt_PVHV){
+ /* e.g. variable = { type => "SCALAR", name => "foo" } */
+ HV* const hv = (HV*)SvRV(variable);
+ SV** svp;
+ STRLEN len;
+ const char* pv;
+
+ svp = hv_fetchs(hv, "name", FALSE);
+ if(!(svp && SvOK(*svp))){
+ croak("You must pass a variable name");
+ }
+ *var_name = SvPV_const(*svp, len);
+ *var_name_len = len;
+ if(len < 1){
+ croak("You must pass a variable name");
+ }
+
+ svp = hv_fetchs(hv, "type", FALSE);
+ if(!(svp && SvOK(*svp))) {
+ croak("You must pass a variable type");
+ }
+ pv = SvPV_nolen_const(*svp);
+ if(strEQ(pv, "SCALAR")){
+ *type = SVt_PV; /* for all the type of scalars */
+ }
+ else if(strEQ(pv, "ARRAY")){
+ *type = SVt_PVAV;
+ }
+ else if(strEQ(pv, "HASH")){
+ *type = SVt_PVHV;
+ }
+ else if(strEQ(pv, "CODE")){
+ *type = SVt_PVCV;
+ }
+ else if(strEQ(pv, "GLOB")){
+ *type = SVt_PVGV;
+ }
+ else if(strEQ(pv, "IO")){
+ *type = SVt_PVIO;
+ }
+ else{
+ croak("I do not recognize that type '%s'", pv);
+ }
+ *type_name = pv;
+ }
+ else {
+ STRLEN len;
+ const char* pv;
+ /* e.g. variable = '$foo' */
+ if(!SvOK(variable)) {
+ croak("You must pass a variable name");
+ }
+ pv = SvPV_const(variable, len);
+ if(len < 2){
+ croak("You must pass a variable name including a sigil");
+ }
+
+ *var_name = pv + 1;
+ *var_name_len = len - 1;
+
+ switch(pv[0]){
+ case '$':
+ *type = SVt_PV; /* for all the types of scalars */
+ *type_name = "SCALAR";
+ break;
+ case '@':
+ *type = SVt_PVAV;
+ *type_name = "ARRAY";
+ break;
+ case '%':
+ *type = SVt_PVHV;
+ *type_name = "HASH";
+ break;
+ case '&':
+ *type = SVt_PVCV;
+ *type_name = "CODE";
+ break;
+ case '*':
+ *type = SVt_PVGV;
+ *type_name = "GLOB";
+ break;
+ default:
+ croak("I do not recognize that sigil '%c'", pv[0]);
+ }
+ }
+}
+
+static GV*
+mop_get_gv(pTHX_ SV* const self, svtype const type, const char* const var_name, I32 const var_name_len, I32 const flags){
+ SV* package_name;
+
+ if(!(flags & ~GV_NOADD_MASK)){ /* for shortcut fetching */
+ SV* const ns = mop_call0(aTHX_ self, mop_namespace);
+ GV** gvp;
+ if(!(SvROK(ns) && SvTYPE(SvRV(ns)) == SVt_PVHV)){
+ croak("namespace() did not return a hash reference");
+ }
+ gvp = (GV**)hv_fetch((HV*)SvRV(ns), var_name, var_name_len, FALSE);
+ if(gvp && isGV_with_GP(*gvp)){
+ return *gvp;
+ }
+ }
+
+ package_name = mop_call0(aTHX_ self, KEY_FOR(name));
+
+ if(!SvOK(package_name)){
+ croak("name() did not return a defined value");
+ }
+
+ return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::%s", package_name, var_name), flags, type);
+}
+
+static SV*
+mop_gv_elem(pTHX_ GV* const gv, svtype const type, I32 const add){
+ SV* sv;
+
+ if(!gv){
+ return NULL;
+ }
+
+ assert(isGV_with_GP(gv));
+
+ switch(type){
+ case SVt_PVAV:
+ sv = (SV*)(add ? GvAVn(gv) : GvAV(gv));
+ break;
+ case SVt_PVHV:
+ sv = (SV*)(add ? GvHVn(gv) : GvHV(gv));
+ break;
+ case SVt_PVCV:
+ sv = (SV*)GvCV(gv);
+ break;
+ case SVt_PVIO:
+ sv = (SV*)(add ? GvIOn(gv) : GvIO(gv));
+ break;
+ case SVt_PVGV:
+ sv = (SV*)gv;
+ break;
+ default: /* SCALAR */
+ sv = add ? GvSVn(gv) : GvSV(gv);
+ break;
+ }
+
+ return sv;
+}
+
+
++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
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);
+
+
+SV*
+add_package_symbol(SV* self, SV* variable, SV* ref = &PL_sv_undef)
+PREINIT:
+ svtype type;
+ const char* type_name;
+ const char* var_name;
+ STRLEN var_name_len;
+ GV* gv;
+CODE:
+ mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
+ gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, GV_ADDMULTI);
+
+ if(SvOK(ref)){ /* add_package_symbol with a value */
+ if(type == SVt_PV){
+ if(!SvROK(ref)){
+ ref = newRV_noinc(newSVsv(ref));
+ sv_2mortal(ref);
+ }
+ }
+ else if(!(SvROK(ref) && SvTYPE(SvRV(ref)) == type)){
+ croak("You must pass a reference of %s for the value of %s", type_name, GvNAME(CvGV(cv)));
+ }
+
+ if(type == SVt_PVCV && GvCV(gv)){
+ /* XXX: clear it before redefinition */
+ SvREFCNT_dec(GvCV(gv));
+ GvCV(gv) = NULL;
+ }
+ sv_setsv_mg((SV*)gv, ref); /* magical assignment into type glob (*glob = $ref) */
+
+ if(type == SVt_PVCV){ /* name a subroutine */
+ CV* const subr = (CV*)SvRV(ref);
+ if(CvANON(subr)
+ && CvGV(subr)
+ && isGV(CvGV(subr))
+ && strEQ(GvNAME(CvGV(subr)), "__ANON__")){
+
+ CvGV(subr) = gv;
+ CvANON_off(subr);
+ }
+ }
+ RETVAL = ref;
+ SvREFCNT_inc_simple_void_NN(ref);
+ }
+ else{
+ SV* const sv = mop_gv_elem(aTHX_ gv, type, GV_ADDMULTI);
+ RETVAL = (sv && GIMME_V != G_VOID) ? newRV_inc(sv) : &PL_sv_undef;
+ }
+OUTPUT:
+ RETVAL
+
+bool
+has_package_symbol(SV* self, SV* variable)
+PREINIT:
+ svtype type;
+ const char* type_name;
+ const char* var_name;
+ STRLEN var_name_len;
+ GV* gv;
+CODE:
+ mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
+ gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, 0);
+ RETVAL = mop_gv_elem(aTHX_ gv, type, FALSE) ? TRUE : FALSE;
+OUTPUT:
+ RETVAL
+
+SV*
+get_package_symbol(SV* self, SV* variable, ...)
+PREINIT:
+ svtype type;
+ const char* type_name;
+ const char* var_name;
+ STRLEN var_name_len;
+ I32 flags = 0;
+ GV* gv;
+ SV* sv;
+CODE:
+ { /* parse options */
+ I32 i;
+ if((items % 2) != 0){
+ croak("Odd number of arguments for get_package_symbol()");
+ }
+ for(i = 2; i < items; i += 2){
+ SV* const opt = ST(i);
+ SV* const val = ST(i+1);
+ if(strEQ(SvPV_nolen_const(opt), "create")){
+ if(SvTRUE(val)){
+ flags |= GV_ADDMULTI;
+ }
+ else{
+ flags &= ~GV_ADDMULTI;
+ }
+ }
+ else{
+ warn("Unknown option \"%"SVf"\" for get_package_symbol()", opt);
+ }
+ }
+ }
+ mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
+ gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, flags);
+ sv = mop_gv_elem(aTHX_ gv, type, FALSE);
+
+ RETVAL = sv ? newRV_inc(sv) : &PL_sv_undef;
+OUTPUT:
+ RETVAL
projects / gitmo/Class-MOP.git / commitdiff