use Scalar::Util 'blessed', 'weaken';
use overload ();
-our $VERSION = '0.57';
+our $VERSION = '0.68';
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Method::Accessor;
+use Moose::Meta::Method::Delegation;
use Moose::Util ();
use Moose::Util::TypeConstraints ();
Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
};
return 0 if !defined($name); # failed to load class
- return Moose::Object::does($self, $name);
+ return $self->Moose::Object::does($name);
}
sub throw_error {
unshift @_, "message" if @_ % 2 == 1;
unshift @_, attr => $self if ref $self;
unshift @_, $class;
- goto $class->can("throw_error"); # to avoid incrementing depth by 1
+ my $handler = $class->can("throw_error"); # to avoid incrementing depth by 1
+ goto $handler;
}
sub new {
my @traits;
if (my $traits = $options{traits}) {
- if ( @traits = grep { not $class->does($_) } map {
- Moose::Util::resolve_metatrait_alias( Attribute => $_ )
- or
- $_
- } @$traits ) {
+ my $i = 0;
+ while ($i < @$traits) {
+ my $trait = $traits->[$i++];
+ next if ref($trait); # options to a trait we discarded
+
+ $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
+ || $trait;
+
+ next if $class->does($trait);
+
+ push @traits, $trait;
+
+ # are there options?
+ push @traits, $traits->[$i++]
+ if $traits->[$i] && ref($traits->[$i]);
+ }
+
+ if (@traits) {
my $anon_class = Moose::Meta::Class->create_anon_class(
superclasses => [ $class ],
roles => [ @traits ],
default coerce required
documentation lazy handles
builder type_constraint
+ definition_context
);
sub legal_options_for_inheritance { @legal_options_for_inheritance }
if ($self->should_coerce && $type_constraint->has_coercion) {
$val = $type_constraint->coerce($val);
}
- $type_constraint->check($val)
- || $self->throw_error("Attribute ("
- . $self->name
- . ") does not pass the type constraint because: "
- . $type_constraint->get_message($val), data => $val, object => $instance);
+ $self->verify_against_type_constraint($val, instance => $instance);
}
$self->set_initial_value($instance, $val);
if ($type_constraint) {
$val = $type_constraint->coerce($val)
if $can_coerce;
- $type_constraint->check($val)
- || $self->throw_error("Attribute ("
- . $slot_name
- . ") does not pass the type constraint because: "
- . $type_constraint->get_message($val), data => $val, object => $instance);
+ $self->verify_against_type_constraint($val, object => $instance);
}
$meta_instance->set_slot_value($instance, $slot_name, $val);
};
my $type_constraint = $self->type_constraint;
$value = $type_constraint->coerce($value)
if ($self->should_coerce);
- $type_constraint->check($value)
- || c$self->throw_error("Attribute (" . $self->name
- . ") does not pass the type constraint because: "
- . $type_constraint->get_message($value), type_constraint => $type_constraint, data => $value);
+ $self->verify_against_type_constraint($value);
}
$self->set_initial_value($instance, $value);
}
return;
}
+sub remove_accessors {
+ my $self = shift;
+ $self->SUPER::remove_accessors(@_);
+ $self->remove_delegation if $self->has_handles;
+ return;
+}
+
sub install_delegation {
my $self = shift;
# to delagate to, see that method for details
my %handles = $self->_canonicalize_handles;
- # find the accessor method for this attribute
- my $accessor = $self->_get_delegate_accessor;
# install the delegation ...
my $associated_class = $self->associated_class;
#cluck("Not delegating method '$handle' because it is a core method") and
next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
- if ('CODE' eq ref($method_to_call)) {
- $associated_class->add_method($handle => Class::MOP::subname($name, $method_to_call));
- }
- else {
- # NOTE:
- # we used to do a goto here, but the
- # goto didn't handle failure correctly
- # (it just returned nothing), so I took
- # that out. However, the more I thought
- # about it, the less I liked it doing
- # the goto, and I prefered the act of
- # delegation being actually represented
- # in the stack trace.
- # - SL
- $associated_class->add_method($handle => Class::MOP::subname($name, sub {
- my $instance = shift;
- my $proxy = $instance->$accessor();
- (defined $proxy)
- || $self->throw_error("Cannot delegate $handle to $method_to_call because " .
- "the value of " . $self->name . " is not defined", method_name => $method_to_call, object => $instance);
- $proxy->$method_to_call(@_);
- }));
- }
+ my $method = $self->_make_delegation_method($handle, $method_to_call);
+
+ $self->associated_class->add_method($method->name, $method);
}
}
-# private methods to help delegation ...
-
-sub _get_delegate_accessor {
+sub remove_delegation {
my $self = shift;
- # find the accessor method for this attribute
- my $accessor = $self->get_read_method_ref;
- # then unpack it if we need too ...
- $accessor = $accessor->body if blessed $accessor;
- # return the accessor
- return $accessor;
+ my %handles = $self->_canonicalize_handles;
+ my $associated_class = $self->associated_class;
+ foreach my $handle (keys %handles) {
+ $self->associated_class->remove_method($handle);
+ }
}
+# private methods to help delegation ...
+
sub _canonicalize_handles {
my $self = shift;
my $handles = $self->handles;
}
elsif ($handle_type eq 'Regexp') {
($self->has_type_constraint)
- || $self->throw_error("Cannot delegate methods based on a RegExpr without a type constraint (isa)", data => $handles);
+ || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
return map { ($_ => $_) }
grep { /$handles/ } $self->_get_delegate_method_list;
}
}
}
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 => $@);
(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);
-
+
return map { $_ => $_ } (
$role_meta->get_method_list,
$role_meta->get_required_method_list
}
}
+sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
+
+sub _make_delegation_method {
+ my ( $self, $handle_name, $method_to_call ) = @_;
+
+ my $method_body;
+
+ $method_body = $method_to_call
+ if 'CODE' 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,
+ );
+}
+
+sub verify_against_type_constraint {
+ my $self = shift;
+ my $val = shift;
+
+ return 1 if !$self->has_type_constraint;
+
+ my $type_constraint = $self->type_constraint;
+
+ $type_constraint->check($val)
+ || $self->throw_error("Attribute ("
+ . $self->name
+ . ") does not pass the type constraint because: "
+ . $type_constraint->get_message($val), data => $val, @_);
+}
+
package Moose::Meta::Attribute::Custom::Moose;
sub register_implementation { 'Moose::Meta::Attribute' }
=item B<install_accessors>
+=item B<remove_accessors>
+
=item B<install_delegation>
+=item B<remove_delegation>
+
=item B<accessor_metaclass>
+=item B<delegation_metaclass>
+
=item B<get_value>
=item B<set_value>
- eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
+ eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
if($@) {
print "Oops: $@\n";
}
-I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
+I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
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
more information on what you can do with this, see the documentation
for L<Moose::Meta::TypeConstraint>.
+=item B<verify_against_type_constraint>
+
+Verifies that the given value is valid under this attribute's type
+constraint, otherwise throws an error.
+
=item B<has_handles>
Returns true if this meta-attribute performs delegation.
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2008 by Infinity Interactive, Inc.
+Copyright 2006-2009 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>