From: Florian Ragwitz Date: Mon, 3 Jan 2011 17:19:22 +0000 (+0100) Subject: Merge branch 'stable' X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d004c8d565f9b314da7652e9368aeb4587ffaa3d;hp=bd2550f8320262fe1ab10f6c0eedc960889d869f;p=gitmo%2FClass-MOP.git Merge branch 'stable' * stable: Version 1.12 remove some undocumented apis from our tests Conflicts: Changes --- diff --git a/Changes b/Changes index 0af9cc0..f8801eb 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,19 @@ 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 @@ -7,11 +21,15 @@ Revision history for Perl extension Class-MOP. 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 diff --git a/Makefile.PL b/Makefile.PL index f9a27ac..0b0c7a3 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -22,12 +22,14 @@ if ( -d '.git' || $ENV{MAINTAINER_MODE} ) { 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'; diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 9430dfe..fc75952 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -187,7 +187,7 @@ Class::MOP::Mixin::HasMethods->meta->add_attribute( # 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 { {} } )) diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index d4b62d7..bf61239 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -148,18 +148,24 @@ sub _set_initial_slot_value { 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; @@ -258,38 +264,91 @@ sub set_initial_value { } 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 ... @@ -404,40 +463,6 @@ sub install_accessors { } -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__ diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index d54fdf9..bf73df1 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -181,18 +181,6 @@ sub _new { }, $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 = ( @@ -549,18 +537,6 @@ sub create { 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 { @@ -608,6 +584,178 @@ sub _construct_instance { 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; @@ -628,13 +776,7 @@ sub _create_meta_instance { 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(@_); @@ -833,8 +975,7 @@ sub get_all_attributes { 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 = @_; @@ -1597,13 +1738,6 @@ metaclass. Returns an instance of the C 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 diff --git a/lib/Class/MOP/Class/Immutable/Trait.pm b/lib/Class/MOP/Class/Immutable/Trait.pm index 0568ef7..86c02cc 100644 --- a/lib/Class/MOP/Class/Immutable/Trait.pm +++ b/lib/Class/MOP/Class/Immutable/Trait.pm @@ -32,7 +32,7 @@ sub _immutable_cannot_call { 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) }; } @@ -80,15 +80,6 @@ sub _method_map { $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__ diff --git a/lib/Class/MOP/Deprecated.pm b/lib/Class/MOP/Deprecated.pm index a5c228d..57200aa 100644 --- a/lib/Class/MOP/Deprecated.pm +++ b/lib/Class/MOP/Deprecated.pm @@ -86,12 +86,7 @@ sub get_method_map { ); 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 diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm index e64a4c2..87d201f 100644 --- a/lib/Class/MOP/Instance.pm +++ b/lib/Class/MOP/Instance.pm @@ -73,8 +73,6 @@ sub _new { 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; diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index 3ce814f..01b3ecf 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -6,6 +6,7 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; our $VERSION = '1.12'; $VERSION = eval $VERSION; @@ -90,113 +91,148 @@ sub _initialize_body { ## 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; diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm index 3eb342f..29017ed 100644 --- a/lib/Class/MOP/Method/Constructor.pm +++ b/lib/Class/MOP/Method/Constructor.pm @@ -6,6 +6,7 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; our $VERSION = '1.12'; $VERSION = eval $VERSION; @@ -74,7 +75,10 @@ sub associated_metaclass { (shift)->{'associated_metaclass'} } 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 @@ -88,107 +92,40 @@ sub _initialize_body { $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; diff --git a/lib/Class/MOP/Method/Generated.pm b/lib/Class/MOP/Method/Generated.pm index a06f115..450c149 100644 --- a/lib/Class/MOP/Method/Generated.pm +++ b/lib/Class/MOP/Method/Generated.pm @@ -5,6 +5,7 @@ use strict; use warnings; use Carp 'confess'; +use Eval::Closure; our $VERSION = '1.12'; $VERSION = eval $VERSION; @@ -18,105 +19,40 @@ sub new { 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; diff --git a/lib/Class/MOP/Method/Inlined.pm b/lib/Class/MOP/Method/Inlined.pm index 5401f06..2cdc3fb 100644 --- a/lib/Class/MOP/Method/Inlined.pm +++ b/lib/Class/MOP/Method/Inlined.pm @@ -12,8 +12,6 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Method::Generated'; -sub _expected_method_class { $_[0]{_expected_method_class} } - sub _uninlined_body { my $self = shift; diff --git a/lib/Class/MOP/Mixin/AttributeCore.pm b/lib/Class/MOP/Mixin/AttributeCore.pm index 4f0a3d4..baa7bd0 100644 --- a/lib/Class/MOP/Mixin/AttributeCore.pm +++ b/lib/Class/MOP/Mixin/AttributeCore.pm @@ -22,16 +22,6 @@ sub has_default { exists $_[0]->{'default'} } 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 } diff --git a/lib/Class/MOP/Mixin/HasAttributes.pm b/lib/Class/MOP/Mixin/HasAttributes.pm index 148e59b..bf05be2 100644 --- a/lib/Class/MOP/Mixin/HasAttributes.pm +++ b/lib/Class/MOP/Mixin/HasAttributes.pm @@ -12,9 +12,6 @@ use Scalar::Util 'blessed'; use base 'Class::MOP::Mixin'; -sub _attribute_map { $_[0]->{'attributes'} } -sub attribute_metaclass { $_[0]->{'attribute_metaclass'} } - sub add_attribute { my $self = shift; diff --git a/lib/Class/MOP/Mixin/HasMethods.pm b/lib/Class/MOP/Mixin/HasMethods.pm index 8d9a807..217e19d 100644 --- a/lib/Class/MOP/Mixin/HasMethods.pm +++ b/lib/Class/MOP/Mixin/HasMethods.pm @@ -15,9 +15,7 @@ use Sub::Name 'subname'; 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; @@ -36,12 +34,6 @@ sub _add_meta_method { ); } -# 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 ) = @_; @@ -68,7 +60,7 @@ sub add_method { $method = $method->clone( package_name => $package_name, name => $method_name, - ) if $method->can('clone'); + ); } $method->attach_to_class($self); @@ -81,17 +73,15 @@ sub add_method { $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 { @@ -99,7 +89,7 @@ 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__' ); } @@ -109,7 +99,10 @@ sub has_method { ( 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 { @@ -133,42 +126,28 @@ 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; @@ -179,34 +158,13 @@ sub remove_method { 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 { @@ -219,6 +177,33 @@ 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__ diff --git a/lib/Class/MOP/Module.pm b/lib/Class/MOP/Module.pm index 716145d..f8d22b2 100644 --- a/lib/Class/MOP/Module.pm +++ b/lib/Class/MOP/Module.pm @@ -33,12 +33,12 @@ sub _new { 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 { diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 8f5e916..e87df55 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -103,39 +103,44 @@ sub namespace { 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; diff --git a/mop.c b/mop.c index a5ded4f..71c043f 100644 --- a/mop.c +++ b/mop.c @@ -106,6 +106,7 @@ mop_get_code_info (SV *coderef, char **pkg, char **name) 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) { @@ -187,14 +188,38 @@ static struct { 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") }; diff --git a/mop.h b/mop.h index e30510d..5547745 100644 --- a/mop.h +++ b/mop.h @@ -19,14 +19,38 @@ 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; diff --git a/t/003_methods.t b/t/003_methods.t index ac985bf..a94ae99 100644 --- a/t/003_methods.t +++ b/t/003_methods.t @@ -379,5 +379,20 @@ is_deeply( '_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; diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index d16e252..ff2e2c5 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -55,17 +55,19 @@ my @class_mop_class_methods = qw( 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 diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t index 112b9c0..6a9bb21 100644 --- a/t/014_attribute_introspection.t +++ b/t/014_attribute_introspection.t @@ -22,6 +22,7 @@ use Class::MOP; initialize_instance_slot _set_initial_slot_value + _make_initializer_writer_callback name has_accessor accessor @@ -62,10 +63,14 @@ use Class::MOP; 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 ); diff --git a/t/081_meta_package_extension.t b/t/081_meta_package_extension.t index 6bf3f6b..e0f393c 100644 --- a/t/081_meta_package_extension.t +++ b/t/081_meta_package_extension.t @@ -29,7 +29,7 @@ use Class::MOP; $class->meta->new_object(__INSTANCE__ => $class->SUPER::new(@_)); } - sub add_package_symbol { + sub add_symbol { my ($self, $variable, $initial_value) = @_; (my $name = $variable) =~ s/^[\$\@\%\&]//; diff --git a/t/310_inline_structor.t b/t/310_inline_structor.t index a1f3e64..27024ce 100644 --- a/t/310_inline_structor.t +++ b/t/310_inline_structor.t @@ -200,8 +200,7 @@ use Class::MOP; 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; } diff --git a/xs/Attribute.xs b/xs/Attribute.xs new file mode 100644 index 0000000..6314af8 --- /dev/null +++ b/xs/Attribute.xs @@ -0,0 +1,9 @@ +#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); diff --git a/xs/AttributeBase.xs b/xs/AttributeBase.xs deleted file mode 100644 index 4381497..0000000 --- a/xs/AttributeBase.xs +++ /dev/null @@ -1,8 +0,0 @@ -#include "mop.h" - -MODULE = Class::MOP::Mixin::AttributeCore PACKAGE = Class::MOP::Mixin::AttributeCore - -PROTOTYPES: DISABLE - -BOOT: - INSTALL_SIMPLE_READER(Mixin::AttributeCore, name); diff --git a/xs/AttributeCore.xs b/xs/AttributeCore.xs new file mode 100644 index 0000000..d495a16 --- /dev/null +++ b/xs/AttributeCore.xs @@ -0,0 +1,18 @@ +#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); diff --git a/xs/Class.xs b/xs/Class.xs new file mode 100644 index 0000000..5c5d5c9 --- /dev/null +++ b/xs/Class.xs @@ -0,0 +1,12 @@ +#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); diff --git a/xs/Generated.xs b/xs/Generated.xs new file mode 100644 index 0000000..57db324 --- /dev/null +++ b/xs/Generated.xs @@ -0,0 +1,9 @@ +#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); diff --git a/xs/HasAttributes.xs b/xs/HasAttributes.xs new file mode 100644 index 0000000..dc59227 --- /dev/null +++ b/xs/HasAttributes.xs @@ -0,0 +1,9 @@ +#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); diff --git a/xs/HasMethods.xs b/xs/HasMethods.xs index 35f5168..0e617eb 100644 --- a/xs/HasMethods.xs +++ b/xs/HasMethods.xs @@ -7,85 +7,38 @@ SV *mop_wrap; 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); } } @@ -94,7 +47,7 @@ MODULE = Class::MOP::Mixin::HasMethods PACKAGE = Class::MOP::Mixin::HasMethods PROTOTYPES: DISABLE void -_full_method_map(self) +_method_map(self) SV *self PREINIT: HV *const obj = (HV *)SvRV(self); @@ -131,3 +84,5 @@ BOOT: 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); diff --git a/xs/Inlined.xs b/xs/Inlined.xs new file mode 100644 index 0000000..a7f1f56 --- /dev/null +++ b/xs/Inlined.xs @@ -0,0 +1,8 @@ +#include "mop.h" + +MODULE = Class::MOP::Method::Inlined PACKAGE = Class::MOP::Method::Inlined + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Method::Inlined, _expected_method_class); diff --git a/xs/Instance.xs b/xs/Instance.xs new file mode 100644 index 0000000..944caed --- /dev/null +++ b/xs/Instance.xs @@ -0,0 +1,8 @@ +#include "mop.h" + +MODULE = Class::MOP::Instance PACKAGE = Class::MOP::Instance + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Instance, associated_metaclass); diff --git a/xs/MOP.xs b/xs/MOP.xs index fd4bf1d..5644cd8 100644 --- a/xs/MOP.xs +++ b/xs/MOP.xs @@ -40,10 +40,16 @@ check_version (SV *klass, SV *required_version) 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 @@ -52,10 +58,16 @@ PROTOTYPES: DISABLE 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 diff --git a/xs/Package.xs b/xs/Package.xs index ce8d390..6c47099 100644 --- a/xs/Package.xs +++ b/xs/Package.xs @@ -4,36 +4,5 @@ MODULE = Class::MOP::Package PACKAGE = Class::MOP::Package 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);