use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
-our $VERSION = '0.88';
+our $VERSION = '0.98';
$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 {
$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 get_read_method {
my $self = shift;
my $reader = $self->reader || $self->accessor;
}
}
-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 {
+sub set_value { shift->set_raw_value(@_) }
+sub get_value { shift->get_raw_value(@_) }
+
+sub set_raw_value {
my ($self, $instance, $value) = @_;
Class::MOP::Class->initialize(ref($instance))
->set_slot_value($instance, $self->name, $value);
}
-sub get_value {
+sub get_raw_value {
my ($self, $instance) = @_;
Class::MOP::Class->initialize(ref($instance))
sub accessor_metaclass { 'Class::MOP::Method::Accessor' }
-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(@_);
-}
-
-sub _process_accessors {
+sub _compute_accessors {
my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
my $method_ctx;
(ref($accessor) eq 'HASH')
|| confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref";
my ($name, $method) = %{$accessor};
- $method = $self->accessor_metaclass->wrap(
+ return ($name, [
+ $self->accessor_metaclass,
$method,
- package_name => $self->associated_class->name,
- name => $name,
+ name => $name,
definition_context => $method_ctx,
- );
- $self->associate_method($method);
- return ($name, $method);
+ ]);
}
- else {
- my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
- my $method;
- eval {
- if ( $method_ctx ) {
- my $desc = "accessor $accessor";
- if ( $accessor ne $self->name ) {
- $desc .= " of attribute " . $self->name;
- }
-
- $method_ctx->{description} = $desc;
- }
-
- $method = $self->accessor_metaclass->new(
- attribute => $self,
- is_inline => $inline_me,
- accessor_type => $type,
- package_name => $self->associated_class->name,
- name => $accessor,
- definition_context => $method_ctx,
- );
- };
- confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@;
- $self->associate_method($method);
- return ($accessor, $method);
+
+ my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
+
+ if ( $method_ctx ) {
+ my $desc = "accessor $accessor";
+ if ( $accessor ne $self->name ) {
+ $desc .= " of attribute " . $self->name;
+ }
+
+ $method_ctx->{description} = $desc;
+ }
+
+ return ($accessor, [
+ $self->accessor_metaclass,
+ attribute => $self,
+ is_inline => $inline_me,
+ accessor_type => $type,
+ name => $accessor,
+ definition_context => $method_ctx,
+ ]);
+}
+
+sub _create_accessors {
+ my ($self, $type, $args) = @_;
+
+ my $accessor_metaclass = shift @{ $args };
+ my $create = (ref $args->[0] && ref $args->[0] eq 'CODE') ? 'wrap' : 'new';
+
+ my $method;
+ try {
+ $method = $accessor_metaclass->$create(
+ @{ $args }, package_name => $self->associated_class->name,
+ );
}
+ catch {
+ confess "Could not create the '$type' method for " . $self->name . " because : $_";
+ };
+
+ $self->associate_method($method);
+
+ return $method;
+}
+
+# for extension compatibility
+sub _process_accessors {
+ my $self = shift;
+ my ($type, $accessor, $generate_as_inline_methods) = @_;
+
+ my ($name, $args) = $self->_compute_accessors(@_);
+ my $method = $self->_create_accessors($type, $args);
+
+ return ($name, $method);
+}
+
+sub compute_all_accessors {
+ my ($self, $inline) = @_;
+
+ my @ret = map {
+ $self->${\"has_$_"}
+ ? ($_ => [$self->_compute_accessors($_ => $self->$_, $inline)])
+ : ()
+ } qw(accessor reader writer predicate clearer);
+
+ return @ret;
}
sub install_accessors {
my $self = shift;
my $inline = shift;
- my $class = $self->associated_class;
- $class->add_method(
- $self->_process_accessors('accessor' => $self->accessor(), $inline)
- ) if $self->has_accessor();
-
- $class->add_method(
- $self->_process_accessors('reader' => $self->reader(), $inline)
- ) if $self->has_reader();
+ my %accessors = $self->compute_all_accessors($inline);
+ while (my ($type, $desc) = each %accessors) {
+ my ($name, $args) = @{ $desc };
+ $self->_install_accessor($name => $self->_create_accessors($type => $args));
+ }
- $class->add_method(
- $self->_process_accessors('writer' => $self->writer(), $inline)
- ) if $self->has_writer();
+ return;
+}
- $class->add_method(
- $self->_process_accessors('predicate' => $self->predicate(), $inline)
- ) if $self->has_predicate();
+sub _install_accessor {
+ my ($self, $name, $method) = @_;
+ my $class = $self->associated_class;
- $class->add_method(
- $self->_process_accessors('clearer' => $self->clearer(), $inline)
- ) if $self->has_clearer();
+ $class->add_method($name => $method);
return;
}
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
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2009 by Infinity Interactive, Inc.
+Copyright 2006-2010 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>