package Mouse::Meta::Attribute;
-use strict;
-use warnings;
+use Mouse::Util qw(:meta); # enables strict and warnings
use Carp ();
-use Mouse::Util qw(:meta);
-
use Mouse::Meta::TypeConstraint;
use Mouse::Meta::Method::Accessor;
+
sub _process_options{
my($class, $name, $args) = @_;
$args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa});
}
elsif(exists $args->{does}){
- # TODO
- # $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does});
+ $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does});
}
$tc = $args->{type_constraint};
}
sub interpolate_class{
- my($class, $name, $args) = @_;
+ my($class, $args) = @_;
if(my $metaclass = delete $args->{metaclass}){
$class = Mouse::Util::resolve_metaclass_alias( Attribute => $metaclass );
}
if (@traits) {
- warn "traits [@traits] for $class\n";
$class = Mouse::Meta::Class->create_anon_class(
superclasses => [ $class ],
roles => \@traits,
return Mouse::Util::TypeConstraints->typecast_constraints($_[0]->associated_class->name, $type, $_[1]);
}
-sub _canonicalize_handles {
- my $self = shift;
- my $handles = shift;
-
- if (ref($handles) eq 'HASH') {
- return %$handles;
- }
- elsif (ref($handles) eq 'ARRAY') {
- return map { $_ => $_ } @$handles;
- }
- else {
- $self->throw_error("Unable to canonicalize the 'handles' option with $handles");
- }
-}
-
sub clone_and_inherit_options{
- my $self = shift;
- my $name = shift;
+ my($self, %args) = @_;
- return ref($self)->new($name, %{$self}, (@_ == 1) ? %{$_[0]} : @_);
+ my($attribute_class, @traits) = ref($self)->interpolate_class(\%args);
+
+ $args{traits} = \@traits if @traits;
+ return $attribute_class->new($self->name, %{$self}, %args);
}
sub clone_parent { # DEPRECATED
}
-sub get_read_method { # DEPRECATED
+sub get_read_method {
$_[0]->{reader} || $_[0]->{accessor}
}
-sub get_write_method { # DEPRECATED
+sub get_write_method {
$_[0]->{writer} || $_[0]->{accessor}
}
$metaclass->name->can($reader);
}
else{
- Mouse::Meta::Method::Accessor->_generate_reader($self, undef, $metaclass);
+ $self->accessor_metaclass->_generate_reader($self, $metaclass);
}
};
}
$metaclass->name->can($reader);
}
else{
- Mouse::Meta::Method::Accessor->_generate_writer($self, undef, $metaclass);
+ $self->accessor_metaclass->_generate_writer($self, $metaclass);
}
};
}
+sub _canonicalize_handles {
+ my($self, $handles) = @_;
+
+ if (ref($handles) eq 'HASH') {
+ return %$handles;
+ }
+ elsif (ref($handles) eq 'ARRAY') {
+ return map { $_ => $_ } @$handles;
+ }
+ else {
+ $self->throw_error("Unable to canonicalize the 'handles' option with $handles");
+ }
+}
+
+
sub associate_method{
my ($attribute, $method) = @_;
$attribute->{associated_methods}++;
return;
}
+sub accessor_metaclass(){ 'Mouse::Meta::Method::Accessor' }
+
sub install_accessors{
my($attribute) = @_;
- my $metaclass = $attribute->{associated_class};
+ my $metaclass = $attribute->{associated_class};
+ my $accessor_class = $attribute->accessor_metaclass;
- foreach my $type(qw(accessor reader writer predicate clearer handles)){
+ foreach my $type(qw(accessor reader writer predicate clearer)){
if(exists $attribute->{$type}){
- my $installer = '_generate_' . $type;
+ my $generator = '_generate_' . $type;
+ my $code = $accessor_class->$generator($attribute, $metaclass);
+ $metaclass->add_method($attribute->{$type} => $code);
+ $attribute->associate_method($code);
+ }
+ }
- Mouse::Meta::Method::Accessor->$installer($attribute, $attribute->{$type}, $metaclass);
+ # install delegation
+ if(exists $attribute->{handles}){
+ my %handles = $attribute->_canonicalize_handles($attribute->{handles});
+ my $reader = $attribute->get_read_method_ref;
- $attribute->{associated_methods}++;
+ while(my($handle_name, $method_to_call) = each %handles){
+ my $code = $accessor_class->_generate_delegation($attribute, $metaclass,
+ $reader, $handle_name, $method_to_call);
+
+ $metaclass->add_method($handle_name => $code);
+ $attribute->associate_method($code);
}
}
+
if($attribute->can('create') != \&create){
# backword compatibility
$attribute->create($metaclass, $attribute->name, %{$attribute});