and called *_package_symbol instead. This is
because they are now more general purpose symbol
table manipulation methods.
+
+ * Class::MOP::Instance
+ - added an is_inlinable method to allow other
+ classes to check before they attempt to optimize.
0.29_02 Thurs. June 22, 2006
++ DEVELOPER RELEASE ++
- name: Point classes
classes:
- 'MOP::Point'
- - 'MOP::Immutable::Point'
- - 'MOP::Local::Point'
+ - 'MOP::Point3D'
+ - 'MOP::Immutable::Point'
+ - 'MOP::Immutable::Point3D'
+ - 'MOP::Installed::Point'
+ - 'MOP::Installed::Point3D'
- 'Plain::Point'
+ - 'Plain::Point3D'
benchmarks:
- class: 'Bench::Construct'
name: object construction
args:
- x: 7
y: 137
- - class: 'Bench::Accessor'
- name: accessor get
- construct:
- x: 4
- y: 6
- accessor: x
- - class: 'Bench::Accessor'
- name: accessor set
- construct:
- x: 4
- y: 6
- accessor: x
- accessor_args: [ 5 ]
+# - class: 'Bench::Accessor'
+# name: accessor get
+# construct:
+# x: 4
+# y: 6
+# accessor: x
+# - class: 'Bench::Accessor'
+# name: accessor set
+# construct:
+# x: 4
+# y: 6
+# accessor: x
+# accessor_args: [ 5 ]
use warnings;
use metaclass;
-__PACKAGE__->meta->add_attribute('x' => (accessor => 'x'));
+__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
__PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
sub new {
-package MOP::Point;
+use lib reverse @INC;
+
+package MOP::Installed::Point;
use strict;
use warnings;
use metaclass;
-__PACKAGE__->meta->add_attribute('x' => (accessor => 'x'));
+__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
__PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
sub new {
-package MOP::Point3D;
+use lib reverse @INC;
+
+package MOP::Installed::Point3D;
use strict;
use warnings;
use warnings;
use metaclass;
-__PACKAGE__->meta->add_attribute('x' => (accessor => 'x'));
+__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
__PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
sub new {
my ( $class, %params ) = @_;
return bless {
- x => $params{x},
+ x => $params{x} || 10,
y => $params{y},
}, $class;
}
# end bootstrapped away method section.
# (all methods below here are kept intact)
+sub is_default_a_coderef {
+ (reftype($_[0]->{default}) && reftype($_[0]->{default}) eq 'CODE')
+}
+
sub default {
- my $self = shift;
- if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
+ my ($self, $instance) = @_;
+ if ($instance && $self->is_default_a_coderef) {
# if the default is a CODE ref, then
# we pass in the instance and default
# can return a value based on that
# instance. Somewhat crude, but works.
- return $self->{default}->(shift);
+ return $self->{default}->($instance);
}
$self->{default};
}
};
}
+sub generate_accessor_method_inline {
+ my $self = shift;
+ my $attr_name = $self->name;
+ my $meta_instance = $self->associated_class->instance_metaclass;
+
+ my $code = eval 'sub {'
+ . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]') . ' if scalar(@_) == 2; '
+ . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
+ . '}';
+ confess "Could not generate inline accessor because : $@" if $@;
+
+ return $code;
+}
+
sub generate_reader_method {
my $self = shift;
my $attr_name = $self->name;
};
}
+sub generate_reader_method_inline {
+ my $self = shift;
+ my $attr_name = $self->name;
+ my $meta_instance = $self->associated_class->instance_metaclass;
+
+ my $code = eval 'sub {'
+ . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
+ . $meta_instance->inline_get_slot_value('$_[0]', $attr_name)
+ . '}';
+ confess "Could not generate inline accessor because : $@" if $@;
+
+ return $code;
+}
+
sub generate_writer_method {
my $self = shift;
my $attr_name = $self->name;
};
}
+sub generate_writer_method_inline {
+ my $self = shift;
+ my $attr_name = $self->name;
+ my $meta_instance = $self->associated_class->instance_metaclass;
+
+ my $code = eval 'sub {'
+ . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]')
+ . '}';
+ confess "Could not generate inline accessor because : $@" if $@;
+
+ return $code;
+}
+
sub generate_predicate_method {
my $self = shift;
my $attr_name = $self->name;
};
}
+sub generate_predicate_method_inline {
+ my $self = shift;
+ my $attr_name = $self->name;
+ my $meta_instance = $self->associated_class->instance_metaclass;
+
+ my $code = eval 'sub {'
+ . 'defined ' . $meta_instance->inline_get_slot_value('$_[0]', $attr_name) . ' ? 1 : 0'
+ . '}';
+ confess "Could not generate inline accessor because : $@" if $@;
+
+ return $code;
+}
+
sub process_accessors {
- my ($self, $type, $accessor) = @_;
+ my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
if (reftype($accessor)) {
(reftype($accessor) eq 'HASH')
|| confess "bad accessor/reader/writer/predicate format, must be a HASH ref";
return ($name, Class::MOP::Attribute::Accessor->wrap($method));
}
else {
- my $generator = $self->can('generate_' . $type . '_method');
+ my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
+ my $generator = $self->can('generate_' . $type . '_method' . ($inline_me ? '_inline' : ''));
($generator)
|| confess "There is no method generator for the type='$type'";
if (my $method = $self->$generator($self->name)) {
}
sub install_accessors {
- my $self = shift;
- my $class = $self->associated_class;
+ my $self = shift;
+ my $inline = shift;
+ my $class = $self->associated_class;
$class->add_method(
- $self->process_accessors('accessor' => $self->accessor())
+ $self->process_accessors('accessor' => $self->accessor(), $inline)
) if $self->has_accessor();
$class->add_method(
- $self->process_accessors('reader' => $self->reader())
+ $self->process_accessors('reader' => $self->reader(), $inline)
) if $self->has_reader();
$class->add_method(
- $self->process_accessors('writer' => $self->writer())
+ $self->process_accessors('writer' => $self->writer(), $inline)
) if $self->has_writer();
$class->add_method(
- $self->process_accessors('predicate' => $self->predicate())
+ $self->process_accessors('predicate' => $self->predicate(), $inline)
) if $self->has_predicate();
+
return;
}
sub is_immutable { 0 }
sub make_immutable {
- my ($class) = @_;
- return Class::MOP::Class::Immutable->make_metaclass_immutable($class);
+ return Class::MOP::Class::Immutable->make_metaclass_immutable(@_);
}
1;
use warnings;
use Carp 'confess';
-use Scalar::Util 'blessed';
+use Scalar::Util 'blessed', 'looks_like_number';
our $VERSION = '0.01';
sub make_immutable { () }
sub make_metaclass_immutable {
- my ($class, $metaclass) = @_;
- $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ];
- $metaclass->{'___get_meta_instance'} = $metaclass->get_meta_instance;
- $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ];
- $metaclass->{'___original_class'} = blessed($metaclass);
+ my ($class, $metaclass, %options) = @_;
+
+ $options{inline_accessors} ||= 1;
+ $options{inline_constructor} ||= 1;
+ $options{constructor_name} ||= 'new';
+
+ my $meta_instance = $metaclass->get_meta_instance;
+ $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ];
+ $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ];
+ $metaclass->{'___get_meta_instance'} = $meta_instance;
+ $metaclass->{'___original_class'} = blessed($metaclass);
+
+ if ($options{inline_accessors}) {
+ foreach my $attr_name ($metaclass->get_attribute_list) {
+ my $attr = $metaclass->get_attribute($attr_name);
+ $attr->install_accessors(1); # inline the accessors
+ }
+ }
+
+ if ($options{inline_constructor}) {
+ $metaclass->add_method(
+ $options{constructor_name},
+ $class->_generate_inline_constructor(
+ \%options,
+ $meta_instance,
+ $metaclass->{'___compute_all_applicable_attributes'}
+ )
+ );
+ }
+
bless $metaclass => $class;
}
-# cached methods
-
-sub get_meta_instance { (shift)->{'___get_meta_instance'} }
-
-sub class_precedence_list {
- @{ (shift)->{'___class_precedence_list'} }
+sub _generate_inline_constructor {
+ my ($class, $options, $meta_instance, $attrs) = @_;
+ # TODO:
+ # the %options should also include a both
+ # a call 'initializer' and call 'SUPER::'
+ # options, which should cover approx 90%
+ # of the possible use cases (even if it
+ # requires some adaption on the part of
+ # the author, after all, nothing is free)
+ my $source = 'sub {';
+ $source .= "\n" . 'my ($class, %params) = @_;';
+ $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class');
+ $source .= ";\n" . (join ";\n" => map {
+ $class->_generate_slot_initializer($meta_instance, $attrs, $_)
+ } 0 .. (@$attrs - 1));
+ $source .= ";\n" . 'return $instance';
+ $source .= ";\n" . '}';
+ warn $source;
+ my $code = eval $source;
+ confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
+ return $code;
}
-sub compute_all_applicable_attributes {
- @{ (shift)->{'___compute_all_applicable_attributes'} }
+sub _generate_slot_initializer {
+ my ($class, $meta_instance, $attrs, $index) = @_;
+ my $attr = $attrs->[$index];
+ my $default;
+ if ($attr->has_default) {
+ if ($attr->is_default_a_coderef) {
+ $default = '$attrs->[' . $index . ']->default($instance)';
+ }
+ else {
+ $default = $attrs->[$index]->default;
+ unless (looks_like_number($default)) {
+ $default = "'$default'";
+ }
+ # TODO:
+ # we should use Data::Dumper to
+ # output any ref's here, obviously
+ # we cannot handle Scalar refs, but
+ # it should work for Array and Hash
+ # refs pretty well.
+ }
+ }
+ $meta_instance->inline_set_slot_value(
+ '$instance',
+ $attr->name,
+ ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
+ )
}
+# cached methods
+
+sub get_meta_instance { (shift)->{'___get_meta_instance'} }
+sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} }
+sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
+
1;
__END__
=head1 DESCRIPTION
+Class::MOP offers many benefits to object oriented development but it
+comes at a cost. Pure Class::MOP classes can be quite a bit slower than
+the typical hand coded Perl classes. This is because just about
+I<everything> is recalculated on the fly, and nothing is cached. The
+reason this is so, is because Perl itself allows you to modify virtually
+everything at runtime. Class::MOP::Class::Immutable offers an alternative
+to this.
+
+By making your class immutable, you are promising that you will not
+modify your inheritence tree or the attributes of any classes in
+that tree. Since runtime modifications like this are fairly atypical
+(and usually recomended against), this is not usally a very hard promise
+to make. For making this promise you are given a wide range of
+optimization options which bring speed close to (and sometimes above)
+those of typical hand coded Perl.
+
=head1 METHODS
=over 4
# inlinable operation snippets
+sub is_inlinable { 1 }
+
+sub inline_create_instance {
+ my ($self, $class_variable) = @_;
+ 'bless {} => ' . $class_variable;
+}
+
sub inline_slot_access {
my ($self, $instance, $slot_name) = @_;
sprintf "%s->{%s}", $instance, $slot_name;
=over 4
+=item B<is_inlinable>
+
+Each meta-instance should override this method to tell Class::MOP if it's
+possible to inline the slot access.
+
+This is currently only used by Class::MOP::Class::Immutable when performing
+optimizations.
+
=item B<inline_slot_access ($instance_structure, $slot_name)>
=item B<inline_get_slot_value ($instance_structure, $slot_name)>
# Class attributes
-my %SIGIL_MAP = (
- '$' => 'SCALAR',
- '@' => 'ARRAY',
- '%' => 'HASH',
- '&' => 'CODE',
-);
+{
+ my %SIGIL_MAP = (
+ '$' => 'SCALAR',
+ '@' => 'ARRAY',
+ '%' => 'HASH',
+ '&' => 'CODE',
+ );
-sub add_package_symbol {
- my ($self, $variable, $initial_value) = @_;
+ sub add_package_symbol {
+ my ($self, $variable, $initial_value) = @_;
- (defined $variable)
- || confess "You must pass a variable name";
+ (defined $variable)
+ || confess "You must pass a variable name";
- my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
- (defined $sigil)
- || confess "The variable name must include a sigil";
+ (defined $sigil)
+ || confess "The variable name must include a sigil";
- (exists $SIGIL_MAP{$sigil})
- || confess "I do not recognize that sigil '$sigil'";
+ (exists $SIGIL_MAP{$sigil})
+ || confess "I do not recognize that sigil '$sigil'";
- no strict 'refs';
- no warnings 'misc';
- *{$self->name . '::' . $name} = $initial_value;
-}
+ no strict 'refs';
+ no warnings 'misc';
+ *{$self->name . '::' . $name} = $initial_value;
+ }
-sub has_package_symbol {
- my ($self, $variable) = @_;
- (defined $variable)
- || confess "You must pass a variable name";
+ sub has_package_symbol {
+ my ($self, $variable) = @_;
+ (defined $variable)
+ || confess "You must pass a variable name";
- my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
- (defined $sigil)
- || confess "The variable name must include a sigil";
+ (defined $sigil)
+ || confess "The variable name must include a sigil";
- (exists $SIGIL_MAP{$sigil})
- || confess "I do not recognize that sigil '$sigil'";
+ (exists $SIGIL_MAP{$sigil})
+ || confess "I do not recognize that sigil '$sigil'";
- no strict 'refs';
- defined *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}} ? 1 : 0;
+ no strict 'refs';
+ defined *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}} ? 1 : 0;
-}
+ }
-sub get_package_symbol {
- my ($self, $variable) = @_;
- (defined $variable)
- || confess "You must pass a variable name";
+ sub get_package_symbol {
+ my ($self, $variable) = @_;
+ (defined $variable)
+ || confess "You must pass a variable name";
- my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
- (defined $sigil)
- || confess "The variable name must include a sigil";
+ (defined $sigil)
+ || confess "The variable name must include a sigil";
- (exists $SIGIL_MAP{$sigil})
- || confess "I do not recognize that sigil '$sigil'";
+ (exists $SIGIL_MAP{$sigil})
+ || confess "I do not recognize that sigil '$sigil'";
- no strict 'refs';
- return *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}};
+ no strict 'refs';
+ return *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}};
-}
+ }
-sub remove_package_symbol {
- my ($self, $variable) = @_;
+ sub remove_package_symbol {
+ my ($self, $variable) = @_;
- (defined $variable)
- || confess "You must pass a variable name";
+ (defined $variable)
+ || confess "You must pass a variable name";
- my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
-
- (defined $sigil)
- || confess "The variable name must include a sigil";
-
- (exists $SIGIL_MAP{$sigil})
- || confess "I do not recognize that sigil '$sigil'";
-
- no strict 'refs';
- if ($SIGIL_MAP{$sigil} eq 'SCALAR') {
- undef ${$self->name . '::' . $name};
- }
- elsif ($SIGIL_MAP{$sigil} eq 'ARRAY') {
- undef @{$self->name . '::' . $name};
- }
- elsif ($SIGIL_MAP{$sigil} eq 'HASH') {
- undef %{$self->name . '::' . $name};
- }
- elsif ($SIGIL_MAP{$sigil} eq 'CODE') {
- undef &{$self->name . '::' . $name};
- }
- else {
- confess "This should never ever ever happen";
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+
+ (defined $sigil)
+ || confess "The variable name must include a sigil";
+
+ (exists $SIGIL_MAP{$sigil})
+ || confess "I do not recognize that sigil '$sigil'";
+
+ no strict 'refs';
+ if ($SIGIL_MAP{$sigil} eq 'SCALAR') {
+ undef ${$self->name . '::' . $name};
+ }
+ elsif ($SIGIL_MAP{$sigil} eq 'ARRAY') {
+ undef @{$self->name . '::' . $name};
+ }
+ elsif ($SIGIL_MAP{$sigil} eq 'HASH') {
+ undef %{$self->name . '::' . $name};
+ }
+ elsif ($SIGIL_MAP{$sigil} eq 'CODE') {
+ undef &{$self->name . '::' . $name};
+ }
+ else {
+ confess "This should never ever ever happen";
+ }
}
+
}
1;
projects / gitmo/Class-MOP.git / commitdiff