Revision history for Perl extension Class-MOP.
+NEXT
+
+ [API CHANGES]
+
+ * The internal code used to generate inlined methods (accessor, constructor,
+ etc.) has been massively rewritten. MooseX modules that do inlining will
+ almost certainly need to be updated as well.
+
+ [ENHANCEMENTS]
+
+ * A lot of code related to managing methods for a class has been tweaked to
+ make it faster. This speeds up compilation time for Class::MOP and Moose,
+ as well modules which use Moose.
+
1.12 Mon, Jan 3, 2011
* Remove usage of undocumented Package::Stash APIs from the tests. This
1.11 Sun, Oct 31, 2010
+ [ENHANCEMENTS]
+
* Replace use of Test::Exception with Test::Fatal. (Karen Etheridge and Dave
Rolsky)
1.10 Mon, Oct 18, 2010
+ [BUG FIXES]
+
* Lots of fixes for edge cases with anon classes. (doy)
1.09 Tue, Oct 5, 2010
requires 'Carp';
requires 'Data::OptList';
requires 'Devel::GlobalDestruction';
+requires 'Eval::Closure';
requires 'List::MoreUtils' => '0.12';
requires 'MRO::Compat' => '0.05';
requires 'Package::DeprecationManager' => '0.10';
-requires 'Package::Stash' => '0.13';
+requires 'Package::Stash' => '0.15';
+requires 'Package::Stash::XS' => '0.17';
requires 'Scalar::Util' => '1.18';
-requires 'Sub::Name' => '0.04';
+requires 'Sub::Name' => '0.05';
requires 'Try::Tiny' => '0.02';
requires 'Task::Weaken';
# NOTE:
# we just alias the original method
# rather than re-produce it here
- '_full_method_map' => \&Class::MOP::Mixin::HasMethods::_full_method_map
+ '_method_map' => \&Class::MOP::Mixin::HasMethods::_method_map
},
default => sub { {} }
))
return $meta_instance->set_slot_value($instance, $slot_name, $value)
unless $self->has_initializer;
- my $callback = sub {
- $meta_instance->set_slot_value($instance, $slot_name, $_[0]);
- };
-
+ my $callback = $self->_make_initializer_writer_callback(
+ $meta_instance, $instance, $slot_name
+ );
+
my $initializer = $self->initializer;
# most things will just want to set a value, so make it first arg
$instance->$initializer($value, $callback, $self);
}
-sub associated_class { $_[0]->{'associated_class'} }
-sub associated_methods { $_[0]->{'associated_methods'} }
+sub _make_initializer_writer_callback {
+ my $self = shift;
+ my ($meta_instance, $instance, $slot_name) = @_;
+
+ return sub {
+ $meta_instance->set_slot_value($instance, $slot_name, $_[0]);
+ };
+}
sub get_read_method {
my $self = shift;
}
sub set_value { shift->set_raw_value(@_) }
-sub get_value { shift->get_raw_value(@_) }
sub set_raw_value {
- my ($self, $instance, $value) = @_;
+ my $self = shift;
+ my ($instance, $value) = @_;
- Class::MOP::Class->initialize(ref($instance))
- ->get_meta_instance
- ->set_slot_value($instance, $self->name, $value);
+ my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
+ return $mi->set_slot_value($instance, $self->name, $value);
}
+sub _inline_set_value {
+ my $self = shift;
+ return $self->_inline_instance_set(@_) . ';';
+}
+
+sub _inline_instance_set {
+ my $self = shift;
+ my ($instance, $value) = @_;
+
+ my $mi = $self->associated_class->get_meta_instance;
+ return $mi->inline_set_slot_value($instance, $self->name, $value);
+}
+
+sub get_value { shift->get_raw_value(@_) }
+
sub get_raw_value {
- my ($self, $instance) = @_;
+ my $self = shift;
+ my ($instance) = @_;
- Class::MOP::Class->initialize(ref($instance))
- ->get_meta_instance
- ->get_slot_value($instance, $self->name);
+ my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
+ return $mi->get_slot_value($instance, $self->name);
+}
+
+sub _inline_get_value {
+ my $self = shift;
+ return $self->_inline_instance_get(@_) . ';';
+}
+
+sub _inline_instance_get {
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $mi = $self->associated_class->get_meta_instance;
+ return $mi->inline_get_slot_value($instance, $self->name);
}
sub has_value {
- my ($self, $instance) = @_;
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
+ return $mi->is_slot_initialized($instance, $self->name);
+}
- Class::MOP::Class->initialize(ref($instance))
- ->get_meta_instance
- ->is_slot_initialized($instance, $self->name);
+sub _inline_has_value {
+ my $self = shift;
+ return $self->_inline_instance_has(@_) . ';';
+}
+
+sub _inline_instance_has {
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $mi = $self->associated_class->get_meta_instance;
+ return $mi->inline_is_slot_initialized($instance, $self->name);
}
sub clear_value {
- my ($self, $instance) = @_;
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
+ return $mi->deinitialize_slot($instance, $self->name);
+}
- Class::MOP::Class->initialize(ref($instance))
- ->get_meta_instance
- ->deinitialize_slot($instance, $self->name);
+sub _inline_clear_value {
+ my $self = shift;
+ return $self->_inline_instance_clear(@_) . ';';
+}
+
+sub _inline_instance_clear {
+ my $self = shift;
+ my ($instance) = @_;
+
+ my $mi = $self->associated_class->get_meta_instance;
+ return $mi->inline_deinitialize_slot($instance, $self->name);
}
## load em up ...
}
-sub inline_get {
- my $self = shift;
- my ($instance) = @_;
-
- return $self->associated_class->get_meta_instance->inline_get_slot_value(
- $instance, $self->name );
-}
-
-sub inline_set {
- my $self = shift;
- my ( $instance, $value ) = @_;
-
- return $self->associated_class->get_meta_instance->inline_set_slot_value(
- $instance, $self->name, $value );
-}
-
-sub inline_has {
- my $self = shift;
- my ($instance) = @_;
-
- return
- $self->associated_class->get_meta_instance
- ->inline_is_slot_initialized( $instance, $self->name );
-}
-
-sub inline_clear {
- my $self = shift;
- my ($instance) = @_;
-
- return
- $self->associated_class->get_meta_instance
- ->inline_deinitialize_slot( $instance, $self->name );
-}
-
1;
__END__
}, $class;
}
-sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef }
-sub update_package_cache_flag {
- my $self = shift;
- # NOTE:
- # we can manually update the cache number
- # since we are actually adding the method
- # to our cache as well. This avoids us
- # having to regenerate the method_map.
- # - SL
- $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
-}
-
## Metaclass compatibility
{
my %base_metaclass = (
return $meta;
}
-## Attribute readers
-
-# NOTE:
-# all these attribute readers will be bootstrapped
-# away in the Class::MOP bootstrap section
-
-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'} }
-
# Instance Construction & Cloning
sub new_object {
return $instance;
}
+sub _inline_new_object {
+ my $self = shift;
+
+ return (
+ 'my $class = shift;',
+ '$class = Scalar::Util::blessed($class) || $class;',
+ $self->_inline_fallback_constructor('$class'),
+ $self->_inline_params('$params', '$class'),
+ $self->_inline_generate_instance('$instance', '$class'),
+ $self->_inline_slot_initializers,
+ $self->_inline_preserve_weak_metaclasses,
+ $self->_inline_extra_init,
+ 'return $instance',
+ );
+}
+
+sub _inline_fallback_constructor {
+ my $self = shift;
+ my ($class) = @_;
+ return (
+ 'return ' . $self->_generate_fallback_constructor($class),
+ 'if ' . $class . ' ne \'' . $self->name . '\';',
+ );
+}
+
+sub _generate_fallback_constructor {
+ my $self = shift;
+ my ($class) = @_;
+ return 'Class::MOP::Class->initialize(' . $class . ')->new_object(@_)',
+}
+
+sub _inline_params {
+ my $self = shift;
+ my ($params, $class) = @_;
+ return (
+ 'my ' . $params . ' = @_ == 1 ? $_[0] : {@_};',
+ );
+}
+
+sub _inline_generate_instance {
+ my $self = shift;
+ my ($inst, $class) = @_;
+ return (
+ 'my ' . $inst . ' = ' . $self->_inline_create_instance($class) . ';',
+ );
+}
+
+sub _inline_create_instance {
+ my $self = shift;
+
+ return $self->get_meta_instance->inline_create_instance(@_);
+}
+
+sub _inline_slot_initializers {
+ my $self = shift;
+
+ my $idx = 0;
+
+ return map { $self->_inline_slot_initializer($_, $idx++) }
+ sort { $a->name cmp $b->name } $self->get_all_attributes;
+}
+
+sub _inline_slot_initializer {
+ my $self = shift;
+ my ($attr, $idx) = @_;
+
+ if (defined(my $init_arg = $attr->init_arg)) {
+ my @source = (
+ 'if (exists $params->{\'' . $init_arg . '\'}) {',
+ $self->_inline_init_attr_from_constructor($attr, $idx),
+ '}',
+ );
+ if (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
+ push @source, (
+ 'else {',
+ @default,
+ '}',
+ );
+ }
+ return @source;
+ }
+ elsif (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
+ return (
+ '{',
+ @default,
+ '}',
+ );
+ }
+ else {
+ return ();
+ }
+}
+
+sub _inline_init_attr_from_constructor {
+ my $self = shift;
+ my ($attr, $idx) = @_;
+
+ my @initial_value = $attr->_inline_set_value(
+ '$instance', '$params->{\'' . $attr->init_arg . '\'}',
+ );
+
+ push @initial_value, (
+ '$attrs->[' . $idx . ']->set_initial_value(',
+ '$instance,',
+ $attr->_inline_instance_get('$instance'),
+ ');',
+ ) if $attr->has_initializer;
+
+ return @initial_value;
+}
+
+sub _inline_init_attr_from_default {
+ my $self = shift;
+ my ($attr, $idx) = @_;
+
+ my $default = $self->_inline_default_value($attr, $idx);
+ return unless $default;
+
+ my @initial_value = $attr->_inline_set_value('$instance', $default);
+
+ push @initial_value, (
+ '$attrs->[' . $idx . ']->set_initial_value(',
+ '$instance,',
+ $attr->_inline_instance_get('$instance'),
+ ');',
+ ) if $attr->has_initializer;
+
+ return @initial_value;
+}
+
+sub _inline_default_value {
+ my $self = shift;
+ my ($attr, $index) = @_;
+
+ if ($attr->has_default) {
+ # NOTE:
+ # default values can either be CODE refs
+ # in which case we need to call them. Or
+ # they can be scalars (strings/numbers)
+ # in which case we can just deal with them
+ # in the code we eval.
+ if ($attr->is_default_a_coderef) {
+ return '$defaults->[' . $index . ']->($instance)';
+ }
+ else {
+ return '$defaults->[' . $index . ']';
+ }
+ }
+ elsif ($attr->has_builder) {
+ return '$instance->' . $attr->builder;
+ }
+ else {
+ return;
+ }
+}
+
+sub _inline_preserve_weak_metaclasses {
+ my $self = shift;
+ if (Class::MOP::metaclass_is_weak($self->name)) {
+ return (
+ $self->_inline_set_mop_slot(
+ '$instance', 'Class::MOP::class_of($class)'
+ ) . ';'
+ );
+ }
+ else {
+ return ();
+ }
+}
+
+sub _inline_extra_init { }
+
sub get_meta_instance {
my $self = shift;
return $instance;
}
-sub inline_create_instance {
- my $self = shift;
-
- return $self->get_meta_instance->inline_create_instance(@_);
-}
-
-sub inline_rebless_instance {
+sub _inline_rebless_instance {
my $self = shift;
return $self->get_meta_instance->inline_rebless_instance_structure(@_);
sub superclasses {
my $self = shift;
- my $isa = $self->get_or_add_package_symbol(
- { sigil => '@', type => 'ARRAY', name => 'ISA' } );
+ my $isa = $self->get_or_add_package_symbol('@ISA');
if (@_) {
my @supers = @_;
Returns an instance of the C<instance_metaclass> to be used in the
construction of a new instance of the class.
-=item B<< $metaclass->inline_create_instance($class_var) >>
-
-=item B<< $metaclass->inline_rebless_instance($instance_var, $class_var) >>
-
-These methods takes variable names, and use them to create an inline snippet
-of code that will create a new instance of the class.
-
=back
=head2 Informational predicates
Carp::confess "The '$name' method cannot be called on an immutable instance";
}
-for my $name (qw/add_method alias_method remove_method add_attribute remove_attribute remove_package_symbol/) {
+for my $name (qw/add_method alias_method remove_method add_attribute remove_attribute remove_package_symbol add_package_symbol/) {
no strict 'refs';
*{__PACKAGE__."::$name"} = sub { _immutable_cannot_call($name) };
}
$self->{__immutable}{_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__
);
my $self = shift;
- my $map = $self->_full_method_map;
-
- $map->{$_} = $self->get_method($_)
- for grep { !blessed( $map->{$_} ) } keys %{$map};
-
- return $map;
+ return { map { $_->name => $_ } $self->_get_local_methods };
}
package
sub _class_name { $_[0]->{_class_name} ||= $_[0]->associated_metaclass->name }
-sub associated_metaclass { $_[0]{'associated_metaclass'} }
-
sub create_instance {
my $self = shift;
bless {}, $self->_class_name;
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
our $VERSION = '1.12';
$VERSION = eval $VERSION;
## generators
sub _generate_accessor_method {
- my $attr = (shift)->associated_attribute;
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
return sub {
- $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
+ if (@_ >= 2) {
+ $attr->set_value($_[0], $_[1]);
+ }
$attr->get_value($_[0]);
};
}
+sub _generate_accessor_method_inline {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
+ return try {
+ $self->_compile_code([
+ 'sub {',
+ 'if (@_ > 1) {',
+ $attr->_inline_set_value('$_[0]', '$_[1]'),
+ '}',
+ $attr->_inline_get_value('$_[0]'),
+ '}',
+ ]);
+ }
+ catch {
+ confess "Could not generate inline accessor because : $_";
+ };
+}
+
sub _generate_reader_method {
- my $attr = (shift)->associated_attribute;
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
return sub {
- confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+ confess "Cannot assign a value to a read-only accessor"
+ if @_ > 1;
$attr->get_value($_[0]);
};
}
+sub _generate_reader_method_inline {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
-sub _generate_writer_method {
- my $attr = (shift)->associated_attribute;
- return sub {
- $attr->set_value($_[0], $_[1]);
+ return try {
+ $self->_compile_code([
+ 'sub {',
+ 'if (@_ > 1) {',
+ # XXX: this is a hack, but our error stuff is terrible
+ $self->_inline_throw_error(
+ '"Cannot assign a value to a read-only accessor"',
+ 'data => \@_'
+ ) . ';',
+ '}',
+ $attr->_inline_get_value('$_[0]'),
+ '}',
+ ]);
+ }
+ catch {
+ confess "Could not generate inline reader because : $_";
};
}
-sub _generate_predicate_method {
- my $attr = (shift)->associated_attribute;
- return sub {
- $attr->has_value($_[0])
- };
+sub _inline_throw_error {
+ my $self = shift;
+ return 'confess ' . $_[0];
}
-sub _generate_clearer_method {
- my $attr = (shift)->associated_attribute;
+sub _generate_writer_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+
return sub {
- $attr->clear_value($_[0])
+ $attr->set_value($_[0], $_[1]);
};
}
-## Inline methods
-
-sub _generate_accessor_method_inline {
+sub _generate_writer_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
- my ( $code, $e ) = $self->_eval_closure(
- {},
- 'sub {'
- . $attr->inline_set( '$_[0]', '$_[1]' )
- . ' if scalar(@_) == 2; '
- . $attr->inline_get('$_[0]') . '}'
- );
- confess "Could not generate inline accessor because : $e" if $e;
-
- return $code;
+ return try {
+ $self->_compile_code([
+ 'sub {',
+ $attr->_inline_set_value('$_[0]', '$_[1]'),
+ '}',
+ ]);
+ }
+ catch {
+ confess "Could not generate inline writer because : $_";
+ };
}
-sub _generate_reader_method_inline {
+sub _generate_predicate_method {
my $self = shift;
my $attr = $self->associated_attribute;
- my ( $code, $e ) = $self->_eval_closure(
- {},
- 'sub {'
- . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
- . $attr->inline_get('$_[0]') . '}'
- );
- confess "Could not generate inline reader because : $e" if $e;
-
- return $code;
+ return sub {
+ $attr->has_value($_[0])
+ };
}
-sub _generate_writer_method_inline {
+sub _generate_predicate_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
- my ( $code, $e ) = $self->_eval_closure(
- {},
- 'sub {' . $attr->inline_set( '$_[0]', '$_[1]' ) . '}'
- );
- confess "Could not generate inline writer because : $e" if $e;
-
- return $code;
+ return try {
+ $self->_compile_code([
+ 'sub {',
+ $attr->_inline_has_value('$_[0]'),
+ '}',
+ ]);
+ }
+ catch {
+ confess "Could not generate inline predicate because : $_";
+ };
}
-sub _generate_predicate_method_inline {
+sub _generate_clearer_method {
my $self = shift;
my $attr = $self->associated_attribute;
- my ( $code, $e ) = $self->_eval_closure(
- {},
- 'sub {' . $attr->inline_has('$_[0]') . '}'
- );
- confess "Could not generate inline predicate because : $e" if $e;
-
- return $code;
+ return sub {
+ $attr->clear_value($_[0])
+ };
}
sub _generate_clearer_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
- my ( $code, $e ) = $self->_eval_closure(
- {},
- 'sub {' . $attr->inline_clear('$_[0]') . '}'
- );
- confess "Could not generate inline clearer because : $e" if $e;
-
- return $code;
+ return try {
+ $self->_compile_code([
+ 'sub {',
+ $attr->_inline_clear_value('$_[0]'),
+ '}',
+ ]);
+ }
+ catch {
+ confess "Could not generate inline clearer because : $_";
+ };
}
1;
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
our $VERSION = '1.12';
$VERSION = eval $VERSION;
sub _attributes {
my $self = shift;
- $self->{'attributes'} ||= [ $self->associated_metaclass->get_all_attributes ]
+ $self->{'attributes'} ||= [
+ sort { $a->name cmp $b->name }
+ $self->associated_metaclass->get_all_attributes
+ ]
}
## method
$self->{'body'} = $self->$method_name;
}
-sub _generate_constructor_method {
- return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
-}
-
-sub _generate_constructor_method_inline {
+sub _eval_environment {
my $self = shift;
-
my $defaults = [map { $_->default } @{ $self->_attributes }];
-
- my $close_over = {
+ return {
'$defaults' => \$defaults,
};
+}
- my $source = 'sub {';
- $source .= "\n" . 'my $class = shift;';
+sub _generate_constructor_method {
+ return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
+}
- $source .= "\n" . 'return Class::MOP::Class->initialize($class)->new_object(@_)';
- $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
+sub _generate_constructor_method_inline {
+ my $self = shift;
- $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
+ my $meta = $self->associated_metaclass;
- $source .= "\n" . 'my $instance = ' . $self->associated_metaclass->inline_create_instance('$class');
- my $idx = 0;
- $source .= ";\n" . (join ";\n" => map {
- $self->_generate_slot_initializer($_, $idx++)
- } @{ $self->_attributes });
- if (Class::MOP::metaclass_is_weak($self->associated_metaclass->name)) {
- $source .= ";\n" . $self->associated_metaclass->_inline_set_mop_slot('$instance', 'Class::MOP::class_of($class)');
- }
- $source .= ";\n" . 'return $instance';
- $source .= ";\n" . '}';
- warn $source if $self->options->{debug};
-
- my ( $code, $e ) = $self->_eval_closure(
- $close_over,
- $source
+ my @source = (
+ 'sub {',
+ $meta->_inline_new_object,
+ '}',
);
- confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e" if $e;
-
- return $code;
-}
-sub _generate_slot_initializer {
- my $self = shift;
- my $attr = shift;
- my $idx = shift;
+ warn join("\n", @source) if $self->options->{debug};
- my $default;
- if ($attr->has_default) {
- $default = $self->_generate_default_value($attr, $idx);
- } elsif( $attr->has_builder ) {
- $default = '$instance->'.$attr->builder;
- }
-
- if ( defined( my $init_arg = $attr->init_arg ) ) {
- return (
- 'if(exists $params->{\''
- . $init_arg . '\'}){' . "\n"
- . $attr->inline_set(
- '$instance',
- '$params->{\'' . $init_arg . '\'}'
- )
- . "\n" . '} '
- . (
- !defined $default ? '' : 'else {' . "\n"
- . $attr->inline_set(
- '$instance',
- $default
- )
- . "\n" . '}'
- )
- );
- }
- elsif ( defined $default ) {
- return (
- $attr->inline_set(
- '$instance',
- $default
- )
- . "\n"
- );
+ my $code = try {
+ $self->_compile_code(\@source);
}
- else {
- return '';
- }
-}
+ catch {
+ my $source = join("\n", @source);
+ confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$_";
+ };
-sub _generate_default_value {
- my ($self, $attr, $index) = @_;
- # NOTE:
- # default values can either be CODE refs
- # in which case we need to call them. Or
- # they can be scalars (strings/numbers)
- # in which case we can just deal with them
- # in the code we eval.
- if ($attr->is_default_a_coderef) {
- return '$defaults->[' . $index . ']->($instance)';
- }
- else {
- return '$defaults->[' . $index . ']';
- }
+ return $code;
}
1;
use warnings;
use Carp 'confess';
+use Eval::Closure;
our $VERSION = '1.12';
$VERSION = eval $VERSION;
confess __PACKAGE__ . " is an abstract base class, you must provide a constructor.";
}
-sub is_inline { $_[0]{is_inline} }
-
-sub definition_context { $_[0]{definition_context} }
-
sub _initialize_body {
confess "No body to initialize, " . __PACKAGE__ . " is an abstract base class";
}
-sub _eval_closure {
- my ($self, $__captures, $sub_body) = @_;
-
- my $code;
-
- my $e = do {
- local $@;
- local $SIG{__DIE__};
- my $source = join
- "\n", (
- map {
- /^([\@\%\$])/
- or die "capture key should start with \@, \% or \$: $_";
- q[my ]
- . $_ . q[ = ]
- . $1
- . q[{$__captures->{']
- . $_ . q['}};];
- } keys %$__captures
- ),
- $sub_body;
-
- $self->_dump_source($source) if $ENV{MOP_PRINT_SOURCE};
-
- $code = eval $source;
- $@;
- };
-
- return ( $code, $e );
-}
-
-sub _dump_source {
- my ( $self, $source ) = @_;
-
- my $output;
- if ( eval { require Perl::Tidy } ) {
- require File::Spec;
-
- my $rc_file = File::Spec->catfile(
- $INC{'Class/MOP/Method/Generated.pm'},
- ('..') x 5,
- 'perltidyrc'
- );
-
- my %p = (
- source => \$source,
- destination => \$output,
- );
- $p{perltidyrc} = $rc_file
- if -f $rc_file;
-
- Perl::Tidy::perltidy(%p);
- }
- else {
- $output = $source;
- }
-
- print STDERR "\n", $self->name, ":\n", $output, "\n";
-}
-
-sub _add_line_directive {
- my ( $self, %args ) = @_;
+sub _generate_description {
+ my ( $self, $context ) = @_;
+ $context ||= $self->definition_context;
- my ( $line, $file );
+ return "generated method (unknown origin)"
+ unless defined $context;
- if ( my $ctx = ( $args{context} || $self->definition_context ) ) {
- $line = $ctx->{line};
- if ( my $desc = $ctx->{description} ) {
- $file = "$desc defined at $ctx->{file}";
- } else {
- $file = $ctx->{file};
- }
+ if (defined $context->{description}) {
+ return "$context->{description} "
+ . "(defined at $context->{file} line $context->{line})";
} else {
- ( $line, $file ) = ( 0, "generated method (unknown origin)" );
+ return "$context->{file} (line $context->{line})";
}
-
- my $code = $args{code};
-
- # if it's an array of lines, join it up
- # don't use newlines so that the definition context is more meaningful
- $code = join(@$code, ' ') if ref $code;
-
- return qq{#line $line "$file"\n} . $code;
}
sub _compile_code {
- my ( $self, %args ) = @_;
-
- my $code = $self->_add_line_directive(%args);
-
- return $self->_eval_closure($args{environment}, $code);
+ my ( $self, @args ) = @_;
+ unshift @args, 'source' if @args % 2;
+ my %args = @args;
+
+ my $context = delete $args{context};
+ my $environment = $self->can('_eval_environment')
+ ? $self->_eval_environment
+ : {};
+
+ return eval_closure(
+ environment => $environment,
+ description => $self->_generate_description($context),
+ %args,
+ );
}
1;
use base 'Class::MOP::Method::Generated';
-sub _expected_method_class { $_[0]{_expected_method_class} }
-
sub _uninlined_body {
my $self = shift;
sub has_initializer { defined $_[0]->{'initializer'} }
sub has_insertion_order { defined $_[0]->{'insertion_order'} }
-sub accessor { $_[0]->{'accessor'} }
-sub reader { $_[0]->{'reader'} }
-sub writer { $_[0]->{'writer'} }
-sub predicate { $_[0]->{'predicate'} }
-sub clearer { $_[0]->{'clearer'} }
-sub builder { $_[0]->{'builder'} }
-sub init_arg { $_[0]->{'init_arg'} }
-sub initializer { $_[0]->{'initializer'} }
-sub definition_context { $_[0]->{'definition_context'} }
-sub insertion_order { $_[0]->{'insertion_order'} }
sub _set_insertion_order { $_[0]->{'insertion_order'} = $_[1] }
sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor }
use base 'Class::MOP::Mixin';
-sub _attribute_map { $_[0]->{'attributes'} }
-sub attribute_metaclass { $_[0]->{'attribute_metaclass'} }
-
sub add_attribute {
my $self = shift;
use base 'Class::MOP::Mixin';
-sub method_metaclass { $_[0]->{'method_metaclass'} }
-sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
-sub _meta_method_class { 'Class::MOP::Method::Meta' }
+sub _meta_method_class { 'Class::MOP::Method::Meta' }
sub _add_meta_method {
my $self = shift;
);
}
-# This doesn't always get initialized in a constructor because there is a
-# weird object construction path for subclasses of Class::MOP::Class. At one
-# point, this always got initialized by calling into the XS code first, but
-# that is no longer guaranteed to happen.
-sub _method_map { $_[0]->{'methods'} ||= {} }
-
sub wrap_method_body {
my ( $self, %args ) = @_;
$method = $method->clone(
package_name => $package_name,
name => $method_name,
- ) if $method->can('clone');
+ );
}
$method->attach_to_class($self);
$self->_method_map->{$method_name} = $method;
- my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
+ my ($current_package, $current_name) = Class::MOP::get_code_info($body);
- if ( !defined $current_name || $current_name =~ /^__ANON__/ ) {
- my $full_method_name = ( $package_name . '::' . $method_name );
- subname( $full_method_name => $body );
- }
+ subname($package_name . '::' . $method_name, $body)
+ unless defined $current_name && $current_name !~ /^__ANON__/;
- $self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name },
- $body,
- );
+ $self->add_package_symbol("&$method_name", $body);
+
+ # we added the method to the method map too, so it's still valid
+ $self->update_package_cache_flag;
}
sub _code_is_mine {
my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
- return $code_package && $code_package eq $self->name
+ return ( $code_package && $code_package eq $self->name )
|| ( $code_package eq 'constant' && $code_name eq '__ANON__' );
}
( defined $method_name && length $method_name )
|| confess "You must define a method name";
- return defined( $self->_get_maybe_raw_method($method_name) );
+ my $method = $self->_get_maybe_raw_method($method_name)
+ or return;
+
+ return defined($self->_method_map->{$method_name} = $method);
}
sub get_method {
sub _get_maybe_raw_method {
my ( $self, $method_name ) = @_;
- my $method_map = $self->_method_map;
- my $map_entry = $method_map->{$method_name};
- my $code = $self->get_package_symbol(
- {
- name => $method_name,
- sigil => '&',
- type => 'CODE',
- }
- );
+ my $map_entry = $self->_method_map->{$method_name};
+ return $map_entry if defined $map_entry;
- # The !$code case seems to happen in some weird cases where methods
- # modifiers are added via roles or some other such bizareness. Honestly, I
- # don't totally understand this, but returning the entry works, and keeps
- # various MX modules from blowing up. - DR
- return $map_entry
- if blessed $map_entry && ( !$code || $map_entry->body == $code );
+ my $code = $self->get_package_symbol("&$method_name");
- unless ($map_entry) {
- return unless $code && $self->_code_is_mine($code);
- }
+ return unless $code && $self->_code_is_mine($code);
return $code;
}
sub remove_method {
my ( $self, $method_name ) = @_;
+
( defined $method_name && length $method_name )
|| confess "You must define a method name";
- my $removed_method = delete $self->_full_method_map->{$method_name};
+ my $removed_method = delete $self->_method_map->{$method_name};
- $self->remove_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name } );
+ $self->remove_package_symbol("&$method_name");
$removed_method->detach_from_class
- if $removed_method && blessed $removed_method;
+ if blessed($removed_method);
# still valid, since we just removed the method from the map
$self->update_package_cache_flag;
sub get_method_list {
my $self = shift;
- my $namespace = $self->namespace;
-
- # Constants may show up as some sort of non-GLOB reference in the
- # namespace hash ref, depending on the Perl version.
- return grep {
- defined $namespace->{$_}
- && ( ref( \$namespace->{$_} ) ne 'GLOB'
- || *{ $namespace->{$_} }{CODE} )
- && $self->has_method($_)
- }
- keys %{$namespace};
+ return keys %{ $self->_full_method_map };
}
-# This should probably be what get_method_list actually does, instead of just
-# returning names. This was created as a much faster alternative to
-# $meta->get_method($_) for $meta->get_method_list
sub _get_local_methods {
my $self = shift;
- my $namespace = $self->namespace;
-
- return map { $self->get_method($_) }
- grep {
- defined $namespace->{$_}
- && ( ref $namespace->{$_}
- || *{ $namespace->{$_} }{CODE} )
- }
- keys %{$namespace};
+ return values %{ $self->_full_method_map };
}
sub _restore_metamethods_from {
}
}
+sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef }
+sub update_package_cache_flag {
+ my $self = shift;
+ # NOTE:
+ # we can manually update the cache number
+ # since we are actually adding the method
+ # to our cache as well. This avoids us
+ # having to regenerate the method_map.
+ # - SL
+ $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
+}
+
+sub _full_method_map {
+ my $self = shift;
+
+ my $pkg_gen = Class::MOP::check_package_cache_flag($self->name);
+
+ if (($self->{_package_cache_flag_full} || -1) != $pkg_gen) {
+ # forcibly reify all method map entries
+ $self->get_method($_)
+ for $self->list_all_package_symbols('CODE');
+ $self->{_package_cache_flag_full} = $pkg_gen;
+ }
+
+ return $self->_method_map;
+}
+
1;
__END__
sub version {
my $self = shift;
- ${$self->get_or_add_package_symbol({ sigil => '$', type => 'SCALAR', name => 'VERSION' })};
+ ${$self->get_or_add_package_symbol('$VERSION')};
}
sub authority {
my $self = shift;
- ${$self->get_or_add_package_symbol({ sigil => '$', type => 'SCALAR', name => 'AUTHORITY' })};
+ ${$self->get_or_add_package_symbol('$AUTHORITY')};
}
sub identifier {
sub add_package_symbol {
my $self = shift;
- $self->_package_stash->add_package_symbol(@_);
+ $self->_package_stash->add_symbol(@_);
}
sub remove_package_glob {
my $self = shift;
- $self->_package_stash->remove_package_glob(@_);
+ $self->_package_stash->remove_glob(@_);
}
# ... these functions deal with stuff on the namespace level
sub has_package_symbol {
my $self = shift;
- $self->_package_stash->has_package_symbol(@_);
+ $self->_package_stash->has_symbol(@_);
}
sub get_package_symbol {
my $self = shift;
- $self->_package_stash->get_package_symbol(@_);
+ $self->_package_stash->get_symbol(@_);
}
sub get_or_add_package_symbol {
my $self = shift;
- $self->_package_stash->get_or_add_package_symbol(@_);
+ $self->_package_stash->get_or_add_symbol(@_);
}
sub remove_package_symbol {
my $self = shift;
- $self->_package_stash->remove_package_symbol(@_);
+ $self->_package_stash->remove_symbol(@_);
}
sub list_all_package_symbols {
my $self = shift;
- $self->_package_stash->list_all_package_symbols(@_);
+ $self->_package_stash->list_all_symbols(@_);
+}
+
+sub get_all_package_symbols {
+ my $self = shift;
+ $self->_package_stash->get_all_symbols(@_);
}
1;
return 1;
}
+/* XXX: eventually this should just use the implementation in Package::Stash */
void
mop_get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud)
{
SV *key;
U32 hash;
} prehashed_keys[key_last] = {
+ DECLARE_KEY(_expected_method_class),
+ DECLARE_KEY(ISA),
+ DECLARE_KEY(VERSION),
+ DECLARE_KEY(accessor),
+ DECLARE_KEY(associated_class),
+ DECLARE_KEY(associated_metaclass),
+ DECLARE_KEY(associated_methods),
+ DECLARE_KEY(attribute_metaclass),
+ DECLARE_KEY(attributes),
+ DECLARE_KEY(body),
+ DECLARE_KEY(builder),
+ DECLARE_KEY(clearer),
+ DECLARE_KEY(constructor_class),
+ DECLARE_KEY(constructor_name),
+ DECLARE_KEY(definition_context),
+ DECLARE_KEY(destructor_class),
+ DECLARE_KEY(immutable_trait),
+ DECLARE_KEY(init_arg),
+ DECLARE_KEY(initializer),
+ DECLARE_KEY(insertion_order),
+ DECLARE_KEY(instance_metaclass),
+ DECLARE_KEY(is_inline),
+ DECLARE_KEY(method_metaclass),
+ DECLARE_KEY(methods),
DECLARE_KEY(name),
DECLARE_KEY(package),
DECLARE_KEY(package_name),
- DECLARE_KEY(body),
+ DECLARE_KEY(predicate),
+ DECLARE_KEY(reader),
+ DECLARE_KEY(wrapped_method_metaclass),
+ DECLARE_KEY(writer),
DECLARE_KEY_WITH_VALUE(package_cache_flag, "_package_cache_flag"),
- DECLARE_KEY(methods),
- DECLARE_KEY(VERSION),
- DECLARE_KEY(ISA),
DECLARE_KEY_WITH_VALUE(_version, "-version")
};
void mop_call_xs (pTHX_ XSPROTO(subaddr), CV *cv, SV **mark);
typedef enum {
+ KEY__expected_method_class,
+ KEY_ISA,
+ KEY_VERSION,
+ KEY_accessor,
+ KEY_associated_class,
+ KEY_associated_metaclass,
+ KEY_associated_methods,
+ KEY_attribute_metaclass,
+ KEY_attributes,
+ KEY_body,
+ KEY_builder,
+ KEY_clearer,
+ KEY_constructor_class,
+ KEY_constructor_name,
+ KEY_definition_context,
+ KEY_destructor_class,
+ KEY_immutable_trait,
+ KEY_init_arg,
+ KEY_initializer,
+ KEY_insertion_order,
+ KEY_instance_metaclass,
+ KEY_is_inline,
+ KEY_method_metaclass,
+ KEY_methods,
KEY_name,
KEY_package,
KEY_package_name,
- KEY_body,
+ KEY_predicate,
+ KEY_reader,
+ KEY_wrapped_method_metaclass,
+ KEY_writer,
KEY_package_cache_flag,
- KEY_methods,
- KEY_VERSION,
- KEY_ISA,
KEY__version,
key_last,
} mop_prehashed_key_t;
'_get_local_methods handles constants properly'
);
+{
+ package DeleteFromMe;
+ sub foo { 1 }
+}
+
+{
+ my $DFMmeta = Class::MOP::Class->initialize('DeleteFromMe');
+ ok($DFMmeta->get_method('foo'));
+
+ delete $DeleteFromMe::{foo};
+
+ ok(!$DFMmeta->get_method('foo'));
+ ok(!DeleteFromMe->can('foo'));
+}
+
done_testing;
initialize reinitialize create
- update_package_cache_flag
- reset_package_cache_flag
-
create_anon_class is_anon_class
instance_metaclass get_meta_instance
- inline_create_instance
- inline_rebless_instance
+ _inline_create_instance
+ _inline_rebless_instance
_inline_get_mop_slot _inline_set_mop_slot _inline_clear_mop_slot
create_meta_instance _create_meta_instance
new_object clone_object
+ _inline_new_object _inline_default_value _inline_preserve_weak_metaclasses
+ _inline_slot_initializer _inline_extra_init _inline_fallback_constructor
+ _inline_generate_instance _inline_params _inline_slot_initializers
+ _inline_init_attr_from_constructor _inline_init_attr_from_default
+ _generate_fallback_constructor
construct_instance _construct_instance
construct_class_instance _construct_class_instance
clone_instance _clone_instance
initialize_instance_slot
_set_initial_slot_value
+ _make_initializer_writer_callback
name
has_accessor accessor
install_accessors
remove_accessors
- inline_get
- inline_set
- inline_has
- inline_clear
+ _inline_get_value
+ _inline_set_value
+ _inline_has_value
+ _inline_clear_value
+ _inline_instance_get
+ _inline_instance_set
+ _inline_instance_has
+ _inline_instance_clear
_new
);
$class->meta->new_object(__INSTANCE__ => $class->SUPER::new(@_));
}
- sub add_package_symbol {
+ sub add_symbol {
my ($self, $variable, $initial_value) = @_;
(my $name = $variable) =~ s/^[\$\@\%\&]//;
sub _inline_destructor {
my $self = shift;
- my ( $code, $e ) = $self->_eval_closure( {}, 'sub { }' );
- die $e if $e;
+ my $code = $self->_compile_code('sub { }');
$self->{body} = $code;
}
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Attribute PACKAGE = Class::MOP::Attribute
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Attribute, associated_class);
+ INSTALL_SIMPLE_READER(Attribute, associated_methods);
+++ /dev/null
-#include "mop.h"
-
-MODULE = Class::MOP::Mixin::AttributeCore PACKAGE = Class::MOP::Mixin::AttributeCore
-
-PROTOTYPES: DISABLE
-
-BOOT:
- INSTALL_SIMPLE_READER(Mixin::AttributeCore, name);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Mixin::AttributeCore PACKAGE = Class::MOP::Mixin::AttributeCore
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, name);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, accessor);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, reader);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, writer);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, predicate);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, clearer);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, builder);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, init_arg);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, initializer);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, definition_context);
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, insertion_order);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Class PACKAGE = Class::MOP::Class
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Class, instance_metaclass);
+ INSTALL_SIMPLE_READER(Class, immutable_trait);
+ INSTALL_SIMPLE_READER(Class, constructor_class);
+ INSTALL_SIMPLE_READER(Class, constructor_name);
+ INSTALL_SIMPLE_READER(Class, destructor_class);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Method::Generated PACKAGE = Class::MOP::Method::Generated
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Method::Generated, is_inline);
+ INSTALL_SIMPLE_READER(Method::Generated, definition_context);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Mixin::HasAttributes PACKAGE = Class::MOP::Mixin::HasAttributes
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Mixin::HasAttributes, attribute_metaclass);
+ INSTALL_SIMPLE_READER_WITH_KEY(Mixin::HasAttributes, _attribute_map, attributes);
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;
+ SV *method;
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)) {
+
+ (void)hv_iterinit(map);
+ while ((method = hv_iternextsv(map, &method_name, &method_name_len))) {
+ SV *body;
+ SV *stash_slot;
+
+ if (!SvROK(method)) {
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;
- }
+ if (sv_isobject(method)) {
+ /* $method_object->body() */
+ body = mop_call0(aTHX_ method, KEY_FOR(body));
+ }
+ else {
+ body = method;
}
- method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
- if ( SvOK(method_slot) ) {
- SV *body;
-
- if ( sv_isobject(method_slot) ) {
- body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */
- }
- else {
- body = method_slot;
- }
-
- if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) {
- continue;
- }
+ stash_slot = *hv_fetch(symbols, method_name, method_name_len, TRUE);
+ if (SvROK(stash_slot) && ((CV*)SvRV(body)) == ((CV*)SvRV(stash_slot))) {
+ 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;
+ /* $map->{$method_name} = undef */
+ sv_setsv(method, &PL_sv_undef);
}
}
PROTOTYPES: DISABLE
void
-_full_method_map(self)
+_method_map(self)
SV *self
PREINIT:
HV *const obj = (HV *)SvRV(self);
mop_method_metaclass = newSVpvs("method_metaclass");
mop_associated_metaclass = newSVpvs("associated_metaclass");
mop_wrap = newSVpvs("wrap");
+ INSTALL_SIMPLE_READER(Mixin::HasMethods, method_metaclass);
+ INSTALL_SIMPLE_READER(Mixin::HasMethods, wrapped_method_metaclass);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Method::Inlined PACKAGE = Class::MOP::Method::Inlined
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Method::Inlined, _expected_method_class);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Instance PACKAGE = Class::MOP::Instance
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Instance, associated_metaclass);
return ret;
}
+EXTERN_C XS(boot_Class__MOP__Mixin__HasAttributes);
EXTERN_C XS(boot_Class__MOP__Mixin__HasMethods);
EXTERN_C XS(boot_Class__MOP__Package);
EXTERN_C XS(boot_Class__MOP__Mixin__AttributeCore);
EXTERN_C XS(boot_Class__MOP__Method);
+EXTERN_C XS(boot_Class__MOP__Method__Inlined);
+EXTERN_C XS(boot_Class__MOP__Method__Generated);
+EXTERN_C XS(boot_Class__MOP__Class);
+EXTERN_C XS(boot_Class__MOP__Attribute);
+EXTERN_C XS(boot_Class__MOP__Instance);
MODULE = Class::MOP PACKAGE = Class::MOP
BOOT:
mop_prehash_keys();
+ MOP_CALL_BOOT (boot_Class__MOP__Mixin__HasAttributes);
MOP_CALL_BOOT (boot_Class__MOP__Mixin__HasMethods);
MOP_CALL_BOOT (boot_Class__MOP__Package);
MOP_CALL_BOOT (boot_Class__MOP__Mixin__AttributeCore);
MOP_CALL_BOOT (boot_Class__MOP__Method);
+ MOP_CALL_BOOT (boot_Class__MOP__Method__Inlined);
+ MOP_CALL_BOOT (boot_Class__MOP__Method__Generated);
+ MOP_CALL_BOOT (boot_Class__MOP__Class);
+ MOP_CALL_BOOT (boot_Class__MOP__Attribute);
+ MOP_CALL_BOOT (boot_Class__MOP__Instance);
# use prototype here to be compatible with get_code_info from Sub::Identify
void
PROTOTYPES: DISABLE
-void
-get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
- SV *self
- type_filter_t filter
- PREINIT:
- HV *stash = NULL;
- HV *symbols = NULL;
- register HE *he;
- PPCODE:
- if ( ! SvROK(self) ) {
- die("Cannot call get_all_package_symbols as a class method");
- }
-
- if (GIMME_V == G_VOID) {
- XSRETURN_EMPTY;
- }
-
- PUTBACK;
-
- if ( (he = hv_fetch_ent((HV *)SvRV(self), KEY_FOR(package), 0, HASH_FOR(package))) ) {
- stash = gv_stashsv(HeVAL(he), 0);
- }
-
-
- if (!stash) {
- XSRETURN_UNDEF;
- }
-
- symbols = mop_get_all_package_symbols(stash, filter);
- PUSHs(sv_2mortal(newRV_noinc((SV *)symbols)));
-
BOOT:
INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);
projects / gitmo/Class-MOP.git / commitdiff