use Scalar::Util 'blessed', 'weaken';
use Try::Tiny;
-our $VERSION = '0.96';
+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
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};
$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 accessor_metaclass { 'Class::MOP::Method::Accessor' }
-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;
- try {
- 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,
- );
+
+ 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;
}
- catch {
- confess "Could not create the '$type' method for " . $self->name . " because : $_";
- };
- $self->associate_method($method);
- return ($accessor, $method);
+
+ $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;
}
Returns the value without going through the accessor. Note that this
works even with write-only accessors.
-=item B<< $sttr->get_raw_value($instance) >>
+=item B<< $attr->get_raw_value($instance) >>
Returns the value without any side effects such as lazy attributes.
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2009 by Infinity Interactive, Inc.
+Copyright 2006-2010 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>