use warnings;
use Scalar::Util 'blessed', 'weaken';
+use List::MoreUtils 'any';
+use Try::Tiny;
use overload ();
-our $VERSION = '0.73_02';
+our $VERSION = '1.08';
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Method::Accessor;
use Moose::Util ();
use Moose::Util::TypeConstraints ();
-use base 'Class::MOP::Attribute';
-
-# options which are not directly used
-# but we store them for metadata purposes
-__PACKAGE__->meta->add_attribute('isa' => (reader => '_isa_metadata'));
-__PACKAGE__->meta->add_attribute('does' => (reader => '_does_metadata'));
-__PACKAGE__->meta->add_attribute('is' => (reader => '_is_metadata'));
-
-# these are actual options for the attrs
-__PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' ));
-__PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' ));
-__PACKAGE__->meta->add_attribute('lazy_build' => (reader => 'is_lazy_build' ));
-__PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce' ));
-__PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' ));
-__PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref'));
-__PACKAGE__->meta->add_attribute('type_constraint' => (
- reader => 'type_constraint',
- predicate => 'has_type_constraint',
-));
-__PACKAGE__->meta->add_attribute('trigger' => (
- reader => 'trigger',
- predicate => 'has_trigger',
-));
-__PACKAGE__->meta->add_attribute('handles' => (
- reader => 'handles',
- predicate => 'has_handles',
-));
-__PACKAGE__->meta->add_attribute('documentation' => (
- reader => 'documentation',
- predicate => 'has_documentation',
-));
+use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore';
+
__PACKAGE__->meta->add_attribute('traits' => (
reader => 'applied_traits',
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 ($self, $role_name) = @_;
- my $name = eval {
+ my $name = try {
Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
};
return 0 if !defined($name); # failed to load class
sub new {
my ($class, $name, %options) = @_;
$class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
+
+ delete $options{__hack_no_process_options};
+
+ my %attrs =
+ ( map { $_ => 1 }
+ grep { defined }
+ map { $_->init_arg() }
+ $class->meta()->get_all_attributes()
+ );
+
+ my @bad = sort grep { ! $attrs{$_} } keys %options;
+
+ if (@bad)
+ {
+ Carp::cluck "Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad";
+ }
+
return $class->SUPER::new($name, %options);
}
sub interpolate_class_and_new {
- my ($class, $name, @args) = @_;
+ my ($class, $name, %args) = @_;
- my ( $new_class, @traits ) = $class->interpolate_class(@args);
-
- $new_class->new($name, @args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
+ my ( $new_class, @traits ) = $class->interpolate_class(\%args);
+
+ $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
}
sub interpolate_class {
- my ($class, %options) = @_;
+ my ($class, $options) = @_;
$class = ref($class) || $class;
- if ( my $metaclass_name = delete $options{metaclass} ) {
+ 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);
+ return $new_class->interpolate_class($options);
} else {
$class = $new_class;
}
my @traits;
- if (my $traits = $options{traits}) {
+ if (my $traits = $options->{traits}) {
my $i = 0;
while ($i < @$traits) {
my $trait = $traits->[$i++];
# ...
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
+ lazy_build weak_ref
);
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')) {
- ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(%options);
+ ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
my %seen;
my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
sub clone {
my ( $self, %params ) = @_;
- my $class = $params{metaclass} || ref $self;
+ my $class = delete $params{metaclass} || ref $self;
my ( @init, @non_init );
## 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};
$options->{accessor} ||= $name;
}
}
+ elsif ($options->{is} eq 'bare') {
+ # do nothing, but don't complain (later) about missing methods
+ }
else {
$class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is});
}
if (exists $options->{isa}) {
if (exists $options->{does}) {
- if (eval { $options->{isa}->can('does') }) {
+ if (try { $options->{isa}->can('does') }) {
($options->{isa}->does($options->{does}))
|| $class->throw_error("Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)", data => $options);
}
$class->throw_error("You can not use lazy_build and default for the same attribute ($name)", data => $options)
if exists $options->{default};
$options->{lazy} = 1;
- $options->{required} = 1;
$options->{builder} ||= "_build_${name}";
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;
$val = $self->_coerce_and_verify( $val, $instance );
$self->set_initial_value($instance, $val);
- $meta_instance->weaken_slot_value($instance, $self->name)
- if ref $val && $self->is_weak_ref;
+
+ if ( ref $val && $self->is_weak_ref ) {
+ $self->_weaken_value($instance);
+ }
}
sub _call_builder {
## 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 {
$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
$value = $self->_coerce_and_verify( $value, $instance );
- my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
- ->get_meta_instance;
+ my @old;
+ if ( $self->has_trigger && $self->has_value($instance) ) {
+ @old = $self->get_value($instance, 'for trigger');
+ }
- $meta_instance->set_slot_value($instance, $attr_name, $value);
+ $self->SUPER::set_value($instance, $value);
- if (ref $value && $self->is_weak_ref) {
- $meta_instance->weaken_slot_value($instance, $attr_name);
+ if ( ref $value && $self->is_weak_ref ) {
+ $self->_weaken_value($instance);
}
if ($self->has_trigger) {
- $self->trigger->($instance, $value);
+ $self->trigger->($instance, $value, @old);
}
}
+sub _weaken_value {
+ my ( $self, $instance ) = @_;
+
+ my $meta_instance = Class::MOP::Class->initialize( blessed($instance) )
+ ->get_meta_instance;
+
+ $meta_instance->weaken_slot_value( $instance, $self->name );
+}
+
sub get_value {
- my ($self, $instance) = @_;
+ my ($self, $instance, $for_trigger) = @_;
if ($self->is_lazy) {
unless ($self->has_value($instance)) {
}
}
- if ($self->should_auto_deref) {
+ if ( $self->should_auto_deref && ! $for_trigger ) {
my $type_constraint = $self->type_constraint;
return;
}
+sub _check_associated_methods {
+ my $self = shift;
+ unless (
+ @{ $self->associated_methods }
+ || ($self->_is_metadata || '') eq 'bare'
+ ) {
+ Carp::cluck(
+ 'Attribute (' . $self->name . ') of class '
+ . $self->associated_class->name
+ . ' has no associated methods'
+ . ' (did you mean to provide an "is" argument?)'
+ . "\n"
+ )
+ }
+}
+
+sub _process_accessors {
+ my $self = shift;
+ my ($type, $accessor, $generate_as_inline_methods) = @_;
+ $accessor = (keys %$accessor)[0] if (ref($accessor)||'') eq 'HASH';
+ my $method = $self->associated_class->get_method($accessor);
+ if ($method && !$method->isa('Class::MOP::Method::Accessor')
+ && (!$self->definition_context
+ || $method->package_name eq $self->definition_context->{package})) {
+ Carp::cluck(
+ "You are overwriting a locally defined method ($accessor) with "
+ . "an accessor"
+ );
+ }
+ $self->SUPER::_process_accessors(@_);
+}
+
sub remove_accessors {
my $self = shift;
$self->SUPER::remove_accessors(@_);
my $method = $self->_make_delegation_method($handle, $method_to_call);
$self->associated_class->add_method($method->name, $method);
- }
+ $self->associate_method($method);
+ }
}
sub remove_delegation {
my %handles = $self->_canonicalize_handles;
my $associated_class = $self->associated_class;
foreach my $handle (keys %handles) {
+ next unless any { $handle eq $_ }
+ map { $_->name }
+ @{ $self->associated_methods };
$self->associated_class->remove_method($handle);
}
}
elsif ($handle_type eq 'CODE') {
return $handles->($self, $self->_find_delegate_metaclass);
}
+ elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
+ return map { $_ => $_ } @{ $handles->methods };
+ }
+ elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) {
+ $handles = $handles->role;
+ }
else {
$self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
}
}
- else {
- my $role_meta = Class::MOP::load_class($handles);
-
- (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
- || $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
+
+ 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 its metaclass is not a Moose::Meta::Role", data => $handles);
+
+ return map { $_ => $_ }
+ grep { $_ ne 'meta' } (
+ $role_meta->get_method_list,
+ map { $_->name } $role_meta->get_required_method_list,
);
- }
}
sub _find_delegate_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);
+ return Class::MOP::Class->initialize($class);
}
elsif (my $role = $self->_does_metadata) {
return Class::MOP::class_of($role);
sub _make_delegation_method {
my ( $self, $handle_name, $method_to_call ) = @_;
- my $method_body;
+ my @curried_arguments;
- $method_body = $method_to_call
- if 'CODE' eq ref($method_to_call);
+ ($method_to_call, @curried_arguments) = @$method_to_call
+ if 'ARRAY' eq ref($method_to_call);
return $self->delegation_metaclass->new(
name => $handle_name,
package_name => $self->associated_class->name,
attribute => $self,
delegate_to_method => $method_to_call,
+ curried_arguments => \@curried_arguments,
);
}
=over 8
-=item * is => 'ro' or 'rw'
+=item * is => 'ro', 'rw', 'bare'
This provides a shorthand for specifying the C<reader>, C<writer>, or
C<accessor> names. If the attribute is read-only ('ro') then it will
read-write attribute, then you will have a C<reader> with the same
name as the attribute, and a C<writer> with the name you provided.
+Use 'bare' when you are deliberately not installing any methods
+(accessor, reader, etc.) associated with this attribute; otherwise,
+Moose will issue a deprecation warning when this attribute is added to a
+metaclass.
+
=item * isa => $type
This option accepts a type. The type can be a string, which should be
Before setting the value, a check is made on the type constraint of
the attribute, if it has one, to see if the value passes it. If the
-value fails to pass, the set operation dies with a L<throw_error>.
+value fails to pass, the set operation dies with a L</throw_error>.
Any coercion to convert values is done before checking the type constraint.
This method overrides the parent to also install delegation methods.
+If, after installing all methods, the attribute object has no associated
+methods, it throws an error unless C<< is => 'bare' >> was passed to the
+attribute constructor. (Trying to add an attribute that has no associated
+methods is almost always an error.)
+
=item B<< $attr->remove_accessors >>
This method overrides the parent to also remove delegation methods.
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
-exception. If you find a bug please either email me, or add the bug
-to cpan-RT.
+See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHOR
=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/Moose.git / blobdiff