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
+ prevents the tests from failing on Package::Stash >= 0.18.
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
*check_package_cache_flag = \&mro::get_pkg_gen;
}
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
# 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 { {} }
))
use Scalar::Util 'blessed', 'weaken';
use Try::Tiny;
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
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__
use Try::Tiny;
use List::MoreUtils 'all';
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
}, $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
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
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__
use strict;
use warnings;
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
);
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
use Scalar::Util 'weaken', 'blessed';
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
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.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
## 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.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
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.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
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})";
}
}
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 Carp 'confess';
use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Method::Generated';
-sub _expected_method_class { $_[0]{_expected_method_class} }
-
sub _uninlined_body {
my $self = shift;
use strict;
use warnings;
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
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 strict;
use warnings;
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Mixin';
-sub _attribute_map { $_[0]->{'attributes'} }
-sub attribute_metaclass { $_[0]->{'attribute_metaclass'} }
-
sub add_attribute {
my $self = shift;
use Class::MOP::Method::Meta;
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
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 };
}
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__
use Carp 'confess';
use Scalar::Util 'blessed';
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
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 {
use Carp 'confess';
use Package::Stash;
- our $VERSION = '1.11';
+ our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
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;
projects / gitmo/Class-MOP.git / commitdiff