use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
-our $VERSION = '0.87';
+our $VERSION = '1.12';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use base 'Class::MOP::Object';
+use base 'Class::MOP::Object', 'Class::MOP::Mixin::AttributeCore';
# NOTE: (meta-circularity)
# This method will be replaced in the
my $name = $options{name};
- (defined $name && $name)
+ (defined $name)
|| confess "You must provide a name for the attribute";
$options{init_arg} = $name
confess("Setting both default and builder is not allowed.")
if exists $options{default};
} else {
- (is_default_a_coderef(\%options))
+ ($class->is_default_a_coderef(\%options))
|| confess("References are not allowed as default values, you must ".
"wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])")
if exists $options{default} && ref $options{default};
sub _new {
my $class = shift;
+
+ return Class::MOP::Class->initialize($class)->new_object(@_)
+ if $class ne __PACKAGE__;
+
my $options = @_ == 1 ? $_[0] : {@_};
bless {
'clearer' => $options->{clearer},
'builder' => $options->{builder},
'init_arg' => $options->{init_arg},
- 'default' => $options->{default},
+ exists $options->{default}
+ ? ('default' => $options->{default})
+ : (),
'initializer' => $options->{initializer},
'definition_context' => $options->{definition_context},
# keep a weakened link to the
$params->{$init_arg},
);
}
- elsif (defined $self->{'default'}) {
+ elsif (exists $self->{'default'}) {
$self->_set_initial_slot_value(
$meta_instance,
$instance,
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);
}
-# NOTE:
-# the next bunch of methods will get bootstrapped
-# away in the Class::MOP bootstrapping section
-
-sub associated_class { $_[0]->{'associated_class'} }
-sub associated_methods { $_[0]->{'associated_methods'} }
-
-sub has_accessor { defined($_[0]->{'accessor'}) }
-sub has_reader { defined($_[0]->{'reader'}) }
-sub has_writer { defined($_[0]->{'writer'}) }
-sub has_predicate { defined($_[0]->{'predicate'}) }
-sub has_clearer { defined($_[0]->{'clearer'}) }
-sub has_builder { defined($_[0]->{'builder'}) }
-sub has_init_arg { defined($_[0]->{'init_arg'}) }
-sub has_default { defined($_[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] }
-
-# end bootstrapped away method section.
-# (all methods below here are kept intact)
-
-sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor }
-sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor }
+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 is_default_a_coderef {
- my ($value) = $_[0]->{'default'};
- return unless ref($value);
- return ref($value) eq 'CODE' || (blessed($value) && $value->isa('Class::MOP::Method'));
-}
-
-sub default {
- my ($self, $instance) = @_;
- if (defined $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'}->($instance);
- }
- $self->{'default'};
-}
-
# slots
sub slots { (shift)->name }
);
}
-sub set_value {
- my ($self, $instance, $value) = @_;
+sub set_value { shift->set_raw_value(@_) }
+
+sub set_raw_value {
+ my $self = shift;
+ my ($instance, $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 = shift;
+ my ($instance) = @_;
+
+ my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
+ return $mi->get_slot_value($instance, $self->name);
+}
- Class::MOP::Class->initialize(ref($instance))
- ->get_meta_instance
- ->set_slot_value($instance, $self->name, $value);
+sub _inline_get_value {
+ my $self = shift;
+ return $self->_inline_instance_get(@_) . ';';
}
-sub get_value {
- my ($self, $instance) = @_;
+sub _inline_instance_get {
+ my $self = shift;
+ my ($instance) = @_;
- Class::MOP::Class->initialize(ref($instance))
- ->get_meta_instance
- ->get_slot_value($instance, $self->name);
+ 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) = @_;
- Class::MOP::Class->initialize(ref($instance))
- ->get_meta_instance
- ->is_slot_initialized($instance, $self->name);
+ my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
+ return $mi->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) = @_;
- Class::MOP::Class->initialize(ref($instance))
- ->get_meta_instance
- ->deinitialize_slot($instance, $self->name);
+ my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
+ return $mi->deinitialize_slot($instance, $self->name);
}
-## load em up ...
+sub _inline_clear_value {
+ my $self = shift;
+ return $self->_inline_instance_clear(@_) . ';';
+}
-sub accessor_metaclass { 'Class::MOP::Method::Accessor' }
+sub _inline_instance_clear {
+ my $self = shift;
+ my ($instance) = @_;
-sub process_accessors {
- Carp::cluck('The process_accessors method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n");
- shift->_process_accessors(@_);
+ my $mi = $self->associated_class->get_meta_instance;
+ return $mi->inline_deinitialize_slot($instance, $self->name);
}
+## load em up ...
+
+sub accessor_metaclass { 'Class::MOP::Method::Accessor' }
+
sub _process_accessors {
my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
else {
my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
my $method;
- eval {
+ try {
if ( $method_ctx ) {
my $desc = "accessor $accessor";
if ( $accessor ne $self->name ) {
name => $accessor,
definition_context => $method_ctx,
);
+ }
+ catch {
+ confess "Could not create the '$type' method for " . $self->name . " because : $_";
};
- confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@;
$self->associate_method($method);
return ($accessor, $method);
}
Class::MOP::Attribute->new(
'doubled' => (
initializer => sub {
- my ( $instance, $value, $set ) = @_;
+ my ( $self, $value, $set, $attr ) = @_;
$set->( $value * 2 );
},
)
Sets the value without going through the accessor. Note that this
works even with read-only attributes.
+=item B<< $attr->set_raw_value($instance, $value) >>
+
+Sets the value with no side effects such as a trigger.
+
+This doesn't actually apply to Class::MOP attributes, only to subclasses.
+
=item B<< $attr->set_initial_value($instance, $value) >>
Sets the value without going through the accessor. This method is only
Returns the value without going through the accessor. Note that this
works even with write-only accessors.
+=item B<< $attr->get_raw_value($instance) >>
+
+Returns the value without any side effects such as lazy attributes.
+
+Doesn't actually apply to Class::MOP attributes, only to subclasses.
+
=item B<< $attr->has_value($instance) >>
Return a boolean indicating whether the attribute has been set in
This does not currently remove methods from the list returned by
C<associated_methods>.
+=item B<< $attr->inline_get >>
+
+=item B<< $attr->inline_set >>
+
+=item B<< $attr->inline_has >>
+
+=item B<< $attr->inline_clear >>
+
+These methods return a code snippet suitable for inlining the relevant
+operation. They expect strings containing variable names to be used in the
+inlining, like C<'$self'> or C<'$_[1]'>.
+
=back
=head2 Introspection
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2009 by Infinity Interactive, Inc.
+Copyright 2006-2010 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
projects / gitmo/Class-MOP.git / blobdiff