use Scalar::Util 'blessed', 'weaken';
use overload ();
-our $VERSION = '0.72';
+our $VERSION = '0.79';
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Method::Accessor;
predicate => 'has_applied_traits',
));
-# we need to have a ->does method in here to
-# more easily support traits, and the introspection
+# we need to have a ->does method in here to
+# more easily support traits, and the introspection
# of those traits. We extend the does check to look
# for metatrait aliases.
sub does {
my ($class, $name, @args) = @_;
my ( $new_class, @traits ) = $class->interpolate_class(@args);
-
+
$new_class->new($name, @args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
}
if ( my $metaclass_name = delete $options{metaclass} ) {
my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
-
+
if ( $class ne $new_class ) {
if ( $new_class->can("interpolate_class") ) {
return $new_class->interpolate_class(%options);
# ...
my @legal_options_for_inheritance = qw(
- default coerce required
- documentation lazy handles
+ default coerce required
+ documentation lazy handles
builder type_constraint
definition_context
lazy_build
sub legal_options_for_inheritance { @legal_options_for_inheritance }
# NOTE/TODO
-# This method *must* be able to handle
-# Class::MOP::Attribute instances as
-# well. Yes, I know that is wrong, but
-# apparently we didn't realize it was
-# doing that and now we have some code
-# which is dependent on it. The real
-# solution of course is to push this
+# This method *must* be able to handle
+# Class::MOP::Attribute instances as
+# well. Yes, I know that is wrong, but
+# apparently we didn't realize it was
+# doing that and now we have some code
+# which is dependent on it. The real
+# solution of course is to push this
# feature back up into Class::MOP::Attribute
# but I not right now, I am too lazy.
-# However if you are reading this and
-# looking for something to do,.. please
+# However if you are reading this and
+# looking for something to do,.. please
# be my guest.
# - stevan
sub clone_and_inherit_options {
my ($self, %options) = @_;
-
+
my %copy = %options;
-
+
my %actual_options;
-
+
# NOTE:
# we may want to extends a Class::MOP::Attribute
- # in which case we need to be able to use the
- # core set of legal options that have always
+ # in which case we need to be able to use the
+ # core set of legal options that have always
# been here. But we allows Moose::Meta::Attribute
# instances to changes them.
# - SL
my @legal_options = $self->can('legal_options_for_inheritance')
? $self->legal_options_for_inheritance
: @legal_options_for_inheritance;
-
+
foreach my $legal_option (@legal_options) {
if (exists $options{$legal_option}) {
$actual_options{$legal_option} = $options{$legal_option};
delete $options{$legal_option};
}
- }
+ }
if ($options{isa}) {
my $type_constraint;
$actual_options{type_constraint} = $type_constraint;
delete $options{isa};
}
-
+
if ($options{does}) {
my $type_constraint;
if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
$actual_options{type_constraint} = $type_constraint;
delete $options{does};
- }
+ }
# NOTE:
- # this doesn't apply to Class::MOP::Attributes,
+ # this doesn't apply to Class::MOP::Attributes,
# so we can ignore it for them.
# - SL
if ($self->can('interpolate_class')) {
my ( @init, @non_init );
- foreach my $attr ( grep { $_->has_value($self) } $self->meta->compute_all_applicable_attributes ) {
+ foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) {
push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
}
## is => rw, accessor => _foo # turns into (accessor => _foo)
## is => ro, accessor => _foo # error, accesor is rw
### -------------------------
-
+
if ($options->{is} eq 'ro') {
$class->throw_error("Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options)
if exists $options->{accessor};
if ($name =~ /^_/) {
$options->{clearer} ||= "_clear${name}";
$options->{predicate} ||= "_has${name}";
- }
+ }
else {
$options->{clearer} ||= "clear_${name}";
$options->{predicate} ||= "has_${name}";
my $value_is_set;
if ( defined($init_arg) and exists $params->{$init_arg}) {
$val = $params->{$init_arg};
- $value_is_set = 1;
+ $value_is_set = 1;
}
else {
# skip it if it's lazy
if ($self->has_default) {
$val = $self->default($instance);
$value_is_set = 1;
- }
+ }
elsif ($self->has_builder) {
$val = $self->_call_builder($instance);
$value_is_set = 1;
return unless $value_is_set;
- if ($self->has_type_constraint) {
- my $type_constraint = $self->type_constraint;
- if ($self->should_coerce && $type_constraint->has_coercion) {
- $val = $type_constraint->coerce($val);
- }
- $self->verify_against_type_constraint($val, instance => $instance);
- }
+ $val = $self->_coerce_and_verify( $val, $instance );
$self->set_initial_value($instance, $val);
$meta_instance->weaken_slot_value($instance, $self->name)
## Slot management
# FIXME:
-# this duplicates too much code from
-# Class::MOP::Attribute, we need to
+# this duplicates too much code from
+# Class::MOP::Attribute, we need to
# refactor these bits eventually.
# - SL
sub _set_initial_slot_value {
}
my $callback = sub {
- my $val = shift;
- if ($type_constraint) {
- $val = $type_constraint->coerce($val)
- if $can_coerce;
- $self->verify_against_type_constraint($val, object => $instance);
- }
+ my $val = $self->_coerce_and_verify( shift, $instance );;
+
$meta_instance->set_slot_value($instance, $slot_name, $val);
};
-
+
my $initializer = $self->initializer;
# most things will just want to set a value, so make it first arg
$self->throw_error("Attribute ($attr_name) is required", object => $instance);
}
- if ($self->has_type_constraint) {
-
- my $type_constraint = $self->type_constraint;
-
- if ($self->should_coerce) {
- $value = $type_constraint->coerce($value);
- }
- $type_constraint->_compiled_type_constraint->($value)
- || $self->throw_error("Attribute ("
- . $self->name
- . ") does not pass the type constraint because "
- . $type_constraint->get_message($value), object => $instance, data => $value);
- }
+ $value = $self->_coerce_and_verify( $value, $instance );
my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
->get_meta_instance;
} elsif ( $self->has_builder ) {
$value = $self->_call_builder($instance);
}
- if ($self->has_type_constraint) {
- my $type_constraint = $self->type_constraint;
- $value = $type_constraint->coerce($value)
- if ($self->should_coerce);
- $self->verify_against_type_constraint($value);
- }
+
+ $value = $self->_coerce_and_verify( $value, $instance );
+
$self->set_initial_value($instance, $value);
}
}
my $method = $self->_make_delegation_method($handle, $method_to_call);
$self->associated_class->add_method($method->name, $method);
- }
+ }
}
sub remove_delegation {
}
}
else {
- Class::MOP::load_class($handles)
- unless Class::MOP::is_class_loaded($handles);
-
- my $role_meta = eval { $handles->meta };
- if ($@) {
- $self->throw_error("Unable to canonicalize the 'handles' option with $handles because : $@", data => $handles, error => $@);
- }
+ Class::MOP::load_class($handles);
+ my $role_meta = Class::MOP::class_of($handles);
(blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
- || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role", data => $handles);
-
+ || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
+
return map { $_ => $_ } (
$role_meta->get_method_list,
$role_meta->get_required_method_list
sub _find_delegate_metaclass {
my $self = shift;
if (my $class = $self->_isa_metadata) {
- # if the class does have
- # a meta method, use it
- return $class->meta if $class->can('meta');
- # otherwise we might be
- # dealing with a non-Moose
- # class, and need to make
- # our own metaclass
+ # we might be dealing with a non-Moose class,
+ # and need to make our own metaclass. if there's
+ # already a metaclass, it will be returned
return Moose::Meta::Class->initialize($class);
}
elsif (my $role = $self->_does_metadata) {
- # our role will always have
- # a meta method
- return $role->meta;
+ return Class::MOP::class_of($role);
}
else {
$self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
);
}
+sub _coerce_and_verify {
+ my $self = shift;
+ my $val = shift;
+ my $instance = shift;
+
+ return $val unless $self->has_type_constraint;
+
+ my $type_constraint = $self->type_constraint;
+ if ($self->should_coerce && $type_constraint->has_coercion) {
+ $val = $type_constraint->coerce($val);
+ }
+
+ $self->verify_against_type_constraint($val, instance => $instance);
+
+ return $val;
+}
+
sub verify_against_type_constraint {
my $self = shift;
my $val = shift;
as a set of additional features on top of the basic feature provided
by that parent class.
+=head1 INHERITANCE
+
+C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
+
=head1 METHODS
Many of the documented below override methods in
projects / gitmo/Moose.git / blobdiff