use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
-our $VERSION = '0.78';
+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
# and a list of the methods
# associated with this attr
'associated_methods' => [],
+ # this let's us keep track of
+ # our order inside the associated
+ # class
+ 'insertion_order' => undef,
}, $class;
}
$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 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'} }
-
-# 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 {
- ('CODE' eq ref($_[0]->{'default'}))
-}
-
-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) = @_;
- 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 get_value {
- my ($self, $instance) = @_;
+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);
+}
+
+sub _inline_get_value {
+ my $self = shift;
+ return $self->_inline_instance_get(@_) . ';';
+}
+
+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) = @_;
+
+ 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(@_) . ';';
+}
- Class::MOP::Class->initialize(ref($instance))
- ->get_meta_instance
- ->is_slot_initialized($instance, $self->name);
+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);
+}
+
+sub _inline_clear_value {
+ my $self = shift;
+ return $self->_inline_instance_clear(@_) . ';';
+}
- Class::MOP::Class->initialize(ref($instance))
- ->get_meta_instance
- ->deinitialize_slot($instance, $self->name);
+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 accessor_metaclass { 'Class::MOP::Method::Accessor' }
-sub process_accessors {
+sub _process_accessors {
my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
my $method_ctx;
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);
}
my $class = $self->associated_class;
$class->add_method(
- $self->process_accessors('accessor' => $self->accessor(), $inline)
+ $self->_process_accessors('accessor' => $self->accessor(), $inline)
) if $self->has_accessor();
$class->add_method(
- $self->process_accessors('reader' => $self->reader(), $inline)
+ $self->_process_accessors('reader' => $self->reader(), $inline)
) if $self->has_reader();
$class->add_method(
- $self->process_accessors('writer' => $self->writer(), $inline)
+ $self->_process_accessors('writer' => $self->writer(), $inline)
) if $self->has_writer();
$class->add_method(
- $self->process_accessors('predicate' => $self->predicate(), $inline)
+ $self->_process_accessors('predicate' => $self->predicate(), $inline)
) if $self->has_predicate();
$class->add_method(
- $self->process_accessors('clearer' => $self->clearer(), $inline)
+ $self->_process_accessors('clearer' => $self->clearer(), $inline)
) if $self->has_clearer();
return;
=over 8
-=item I<init_arg>
+=item * init_arg
This is a string value representing the expected key in an
initialization hash. For instance, if we have an C<init_arg> value of
C<-foo>, then the following code will Just Work.
- MyClass->meta->construct_instance( -foo => 'Hello There' );
+ MyClass->meta->new_object( -foo => 'Hello There' );
If an init_arg is not assigned, it will automatically use the
attribute's name. If C<init_arg> is explicitly set to C<undef>, the
attribute cannot be specified during initialization.
-=item I<builder>
+=item * builder
This provides the name of a method that will be called to initialize
the attribute. This method will be called on the object after it is
constructed. It is expected to return a valid value for the attribute.
-=item I<default>
+=item * default
This can be used to provide an explicit default for initializing the
attribute. If the default you provide is a subroutine reference, then
particular order, so you cannot rely on the value of some other
attribute when generating the default.
-=item I<initializer>
+=item * initializer
This option can be either a method name or a subroutine
reference. This method will be called when setting the attribute's
Class::MOP::Attribute->new(
'doubled' => (
initializer => sub {
- my ( $instance, $value, $set ) = @_;
+ my ( $self, $value, $set, $attr ) = @_;
$set->( $value * 2 );
},
)
should be a subroutine reference, which will be installed as the
method itself.
-=over 4
+=over 8
-=item I<accessor>
+=item * accessor
An C<accessor> is a standard Perl-style read/write accessor. It will
return the value of the attribute, and if a value is passed as an
$object->set_something(undef);
-=item I<reader>
+=item * reader
This is a basic read-only accessor. It returns the value of the
attribute.
-=item I<writer>
+=item * writer
This is a basic write accessor, it accepts a single argument, and
assigns that value to the attribute.
$object->set_something(undef);
-=item I<predicate>
+=item * predicate
The predicate method returns a boolean indicating whether or not the
attribute has been explicitly set.
Note that the predicate returns true even if the attribute was set to
a false value (C<0> or C<undef>).
-=item I<clearer>
+=item * clearer
This method will uninitialize the attribute. After an attribute is
cleared, its C<predicate> will return false.
+=item * definition_context
+
+Mostly, this exists as a hook for the benefit of Moose.
+
+This option should be a hash reference containing several keys which
+will be used when inlining the attribute's accessors. The keys should
+include C<line>, the line number where the attribute was created, and
+either C<file> or C<description>.
+
+This information will ultimately be used when eval'ing inlined
+accessor code so that error messages report a useful line and file
+name.
+
=back
=item B<< $attr->clone(%options) >>
=item B<< $attr->name >>
+Returns the attribute's name.
+
=item B<< $attr->accessor >>
=item B<< $attr->reader >>
The C<accessor>, C<reader>, C<writer>, C<predicate>, and C<clearer>
methods all return exactly what was passed to the constructor, so it
-can be either a string containing a method name, or a hash refrence.
+can be either a string containing a method name, or a hash reference.
=item B<< $attr->initializer >>
-Returns the intializer as passed to the constructor, so this may be
+Returns the initializer as passed to the constructor, so this may be
either a method name or a subroutine reference.
=item B<< $attr->init_arg >>
always return a subroutine reference, regardless of whether or not the
attribute is read- or write-only.
+=item B<< $attr->insertion_order >>
+
+If this attribute has been inserted into a class, this returns a zero
+based index regarding the order of insertion.
+
=back
=head2 Informational predicates
=item B<< $attr->has_builder >>
+=item B<< $attr->has_insertion_order >>
+
+This will be I<false> if this attribute has not be inserted into a class
+
=back
=head2 Value management
-These methods are basically "backdoors" to the instance, and can be
+These methods are basically "back doors" to the instance, and can be
used to bypass the regular accessors, but still stay within the MOP.
These methods are not for general use, and should only be used if you
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
accessors. It is typically called from the L<Class::MOP::Class>
C<add_attribute> method.
-This method will call C<< $attr->process_accessors >> for each of the
-possible method types (accessor, reader, writer & predicate).
-
-=item B<< $attr->process_accessors($type, $value) >>
-
-This method takes a C<$type> (accessor, reader, writer or predicate), and
-a C<$value> (the value passed into the constructor for each of the
-different types).
-
-It will then either generate the method itself (using the
-C<generate_*_method> methods listed below) or it will use the custom
-method passed through the constructor.
-
-This method is mostly intended for internal use from the C<<
-$attr->install_accessors >> method.
-
=item B<< $attr->remove_accessors >>
This method removes all of the accessors associated with the
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
=over 4
-=item B<< $attr->meta >>
+=item B<< Class::MOP::Attribute->meta >>
This will return a L<Class::MOP::Class> instance for this class.
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2008 by Infinity Interactive, Inc.
+Copyright 2006-2010 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
projects / gitmo/Class-MOP.git / blobdiff