use Scalar::Util 'blessed', 'weaken';
use overload ();
-our $VERSION = '0.57';
+our $VERSION = '0.66';
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 wantarray ? %{ $rv } : $rv;
}
else {
- $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, data => $type_constraint);
+ $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
}
}
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>
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<Carp/confess>.
+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.
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>
projects / gitmo/Moose.git / blobdiff