TODO
-------------------------------------------------------------------------------
-- make way to iterate over all Moose classes
-
- roles
Need to figure out the details of composite roles
has => sub {
my $class = $CALLER;
return subname 'Moose::has' => sub {
- my ($name, %options) = @_;
+ my ($name, %options) = @_;
my $meta = $class->meta;
if ($name =~ /^\+(.*)/) {
my $inherited_attr = $meta->find_attribute_by_name($1);
return \&Scalar::Util::blessed;
},
all_methods => sub {
- subname 'Moose::all_methods' => sub () {
- sub {
- my ($class, $delegate_class) = @_;
- $delegate_class->compute_all_applicable_methods();
- }
- }
+ subname 'Moose::all_methods' => sub () { qr/.*/ }
}
);
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',
+ predicate => 'has_isa_metadata',
+));
+__PACKAGE__->meta->add_attribute('does' => (
+ reader => 'does_metadata',
+ predicate => 'has_does_metadata',
+));
+__PACKAGE__->meta->add_attribute('is' => (
+ reader => 'is_metadata',
+ predicate => 'has_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('coerce' => (reader => 'should_coerce' ));
reader => 'trigger',
predicate => 'has_trigger',
));
+__PACKAGE__->meta->add_attribute('handles' => (
+ reader => 'handles',
+ predicate => 'has_handles',
+));
sub new {
my ($class, $name, %options) = @_;
$class->_process_options($name, \%options);
- $class->SUPER::new($name, %options);
+ my $self = $class->SUPER::new($name, %options);
+ return $self;
}
sub clone_and_inherit_options {
sub _process_options {
my ($class, $name, $options) = @_;
+
if (exists $options->{is}) {
if ($options->{is} eq 'ro') {
$options->{reader} = $name;
|| confess "Cannot have a trigger on a read-only attribute";
}
elsif ($options->{is} eq 'rw') {
- $options->{accessor} = $name;
- ((reftype($options->{trigger}) || '') eq 'CODE')
- || confess "A trigger must be a CODE reference"
- if exists $options->{trigger};
+ $options->{accessor} = $name;
+ }
+ else {
+ confess "I do not understand this option (is => " . $options->{is} . ")"
}
}
+ # process and check trigger here ...
+
+
if (exists $options->{isa}) {
if (exists $options->{does}) {
return $sub;
}
+sub install_accessors {
+ my $self = shift;
+ $self->SUPER::install_accessors(@_);
+
+ if ($self->has_handles) {
+
+ # NOTE:
+ # Here we canonicalize the 'handles' option
+ # this will sort out any details and always
+ # return an hash of methods which we want
+ # to delagate to, see that method for details
+ my %handles = $self->_canonicalize_handles();
+
+ # find the name of the accessor for this attribute
+ my $accessor_name = $self->reader || $self->accessor;
+ (defined $accessor_name)
+ || confess "You cannot install delegation without a reader or accessor for the attribute";
+
+ # make sure we handle HASH accessors correctly
+ ($accessor_name) = keys %{$accessor_name}
+ if ref($accessor_name) eq 'HASH';
+
+ # install the delegation ...
+ my $associated_class = $self->associated_class;
+ foreach my $handle (keys %handles) {
+ my $method_to_call = $handles{$handle};
+
+ (!$associated_class->has_method($handle))
+ || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
+
+ if ((reftype($method_to_call) || '') eq 'CODE') {
+ $associated_class->add_method($handle => $method_to_call);
+ }
+ else {
+ $associated_class->add_method($handle => sub {
+ ((shift)->$accessor_name())->$method_to_call(@_);
+ });
+ }
+ }
+ }
+
+ return;
+}
+
+sub _canonicalize_handles {
+ my $self = shift;
+ my $handles = $self->handles;
+ if (ref($handles) eq 'HASH') {
+ return %{$handles};
+ }
+ elsif (ref($handles) eq 'ARRAY') {
+ return map { $_ => $_ } @{$handles};
+ }
+ elsif (ref($handles) eq 'Regexp') {
+ ($self->has_type_constraint)
+ || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
+ return map { ($_ => $_) }
+ grep { $handles } $self->_get_delegate_method_list;
+ }
+ elsif (ref($handles) eq 'CODE') {
+ return $handles->($self, $self->_find_delegate_metaclass);
+ }
+ else {
+ confess "Unable to canonicalize the 'handles' option with $handles";
+ }
+}
+
+sub _find_delegate_metaclass {
+ my $self = shift;
+ if ($self->has_isa_metadata) {
+ 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
+ return Moose::Meta::Class->initialize($class);
+ }
+ elsif ($self->has_does_metadata) {
+ # our role will always have
+ # a meta method
+ return $self->does_metadata->meta;
+ }
+ else {
+ confess "Cannot find delegate metaclass for attribute " . $self->name;
+ }
+}
+
+sub _get_delegate_method_list {
+ my $self = shift;
+ my $meta = $self->_find_delegate_metaclass;
+ if ($meta->isa('Class::MOP::Class')) {
+ return map { $_->{name} }
+ grep { $_->{class} ne 'Moose::Object' }
+ $meta->compute_all_applicable_methods;
+ }
+ elsif ($meta->isa('Moose::Meta::Role')) {
+ return $meta->get_method_list;
+ }
+ else {
+ confess "Unable to recognize the delegate metaclass '$meta'";
+ }
+}
+
1;
__END__
=item B<generate_reader_method>
+=item B<install_accessors>
+
=back
=head2 Additional Moose features
more information on what you can do with this, see the documentation
for L<Moose::Meta::TypeConstraint>.
+=item B<has_handles>
+
+Returns true if this meta-attribute performs delegation.
+
+=item B<handles>
+
+This returns the value which was passed into the handles option.
+
=item B<is_weak_ref>
Returns true if this meta-attribute produces a weak reference.
return $self->SUPER::has_method($method_name);
}
-sub add_attribute {
- my ($self, $name, %params) = @_;
-
- my @delegations;
- if ( my $delegation = delete $params{handles} ) {
- my @method_names_or_hashes = $self->compute_delegation( $name, $delegation, \%params );
- @delegations = $self->get_delegatable_methods( @method_names_or_hashes );
- }
-
- my $ret = $self->SUPER::add_attribute( $name, %params );
-
- if ( @delegations ) {
- my $attr = $self->get_attribute( $name );
- $self->generate_delgate_method( $attr, $_ ) for $self->filter_delegations( $attr, @delegations );
- }
-
- return $ret;
-}
-
-sub filter_delegations {
- my ( $self, $attr, @delegations ) = @_;
- grep {
- my $new_name = $_->{new_name} || $_->{name};
- no warnings "uninitialized";
- $_->{no_filter} or (
- !$self->name->can( $new_name ) and
- $attr->accessor ne $new_name and
- $attr->reader ne $new_name and
- $attr->writer ne $new_name
- );
- } @delegations;
-}
-
-sub generate_delgate_method {
- my ( $self, $attr, $method ) = @_;
-
- # FIXME like generated accessors these methods must be regenerated
- # FIXME the reader may not work for subclasses with weird instances
-
- my $make = $method->{generator} || sub {
- my ( $self, $attr, $method ) = @_;
-
- my $method_name = $method->{name};
- my $reader = $attr->generate_reader_method();
-
- return sub {
- if ( Scalar::Util::blessed( my $delegate = shift->$reader ) ) {
- return $delegate->$method_name( @_ );
- }
- return;
- };
- };
-
- my $new_name = $method->{new_name} || $method->{name};
- $self->add_method( $new_name, $make->( $self, $attr, $method ) );
-}
-
-sub compute_delegation {
- my ( $self, $attr_name, $delegation, $params ) = @_;
-
-
- # either it's a concrete list of method names
- return $delegation unless ref $delegation; # single method name
- return @$delegation if reftype($delegation) eq "ARRAY";
-
- # or it's a generative api
- my $delegator_meta = $self->_guess_attr_class_or_role( $attr_name, $params );
- $self->generate_delegation_list( $delegation, $delegator_meta );
-}
-
-sub get_delegatable_methods {
- my ( $self, @names_or_hashes ) = @_;
- map { ref($_) ? $_ : { name => $_ } } @names_or_hashes;
-}
-
-sub generate_delegation_list {
- my ( $self, $delegation, $delegator_meta ) = @_;
-
- if ( reftype($delegation) eq "CODE" ) {
- return $delegation->( $self, $delegator_meta );
- } elsif ( blessed($delegation) eq "Regexp" ) {
- confess "For regular expression support the delegator class/role must use a Class::MOP::Class metaclass"
- unless $delegator_meta->isa( "Class::MOP::Class" );
- return grep { $_->{name} =~ /$delegation/ } $delegator_meta->compute_all_applicable_methods();
- } else {
- confess "The 'handles' specification '$delegation' is not supported";
- }
-}
-
-sub _guess_attr_class_or_role {
- my ( $self, $attr, $params ) = @_;
-
- my ( $isa, $does ) = @{ $params }{qw/isa does/};
-
- confess "Generative delegations must explicitly specify a class or a role for the attribute's type"
- unless $isa || $does;
-
- for (grep { blessed($_) } $isa, $does) {
- confess "You must use classes/roles, not type constraints to use delegation ($_)"
- unless $_->isa( "Moose::Meta::Class" );
- }
-
- confess "Cannot have an isa option and a does option if the isa does not do the does"
- if $isa and $does and $isa->can("does") and !$isa->does( $does );
-
- # if it's a class/role name make it into a meta object
- for ($isa, $does) {
- $_ = $_->meta if defined and !ref and $_->can("meta");
- }
-
- $isa = Class::MOP::Class->initialize($isa) if $isa and !ref($isa);
-
- return $isa || $does;
-}
-
sub add_override_method_modifier {
my ($self, $name, $method, $_super_package) = @_;
# need this for roles ...
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 46;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+}
+
+# the canonical form of of the 'handles'
+# option is the hash ref mapping a
+# method name to the delegated method name
+
+{
+ package Foo;
+ use strict;
+ use warnings;
+ use Moose;
+
+ has 'bar' => (is => 'rw', default => 10);
+
+ package Bar;
+ use strict;
+ use warnings;
+ use Moose;
+
+ has 'foo' => (
+ is => 'rw',
+ default => sub { Foo->new },
+ handles => { 'foo_bar' => 'bar' }
+ );
+}
+
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+
+ok($bar->foo, '... we have something in bar->foo');
+isa_ok($bar->foo, 'Foo');
+
+is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
+
+can_ok($bar, 'foo_bar');
+is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
+
+my $foo = Foo->new(bar => 25);
+isa_ok($foo, 'Foo');
+
+is($foo->bar, 25, '... got the right foo->bar');
+
+lives_ok {
+ $bar->foo($foo);
+} '... assigned the new Foo to Bar->foo';
+
+is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
+
+is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
+is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
+
+# we also support an array based format
+# which assumes that the name is the same
+# on either end
+
+{
+ package Engine;
+ use strict;
+ use warnings;
+ use Moose;
+
+ sub go { 'Engine::go' }
+ sub stop { 'Engine::stop' }
+
+ package Car;
+ use strict;
+ use warnings;
+ use Moose;
+
+ has 'engine' => (
+ is => 'rw',
+ default => sub { Engine->new },
+ handles => [ 'go', 'stop' ]
+ );
+}
+
+my $car = Car->new;
+isa_ok($car, 'Car');
+
+isa_ok($car->engine, 'Engine');
+can_ok($car->engine, 'go');
+can_ok($car->engine, 'stop');
+
+is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
+is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');
+
+can_ok($car, 'go');
+can_ok($car, 'stop');
+
+is($car->go, 'Engine::go', '... got the right value from ->go');
+is($car->stop, 'Engine::stop', '... got the right value from ->stop');
+
+# and we support regexp delegation
+
+{
+ package Baz;
+ use strict;
+ use warnings;
+ use Moose;
+
+ sub foo { 'Baz::foo' }
+ sub bar { 'Baz::bar' }
+ sub boo { 'Baz::boo' }
+
+ package Baz::Proxy1;
+ use strict;
+ use warnings;
+ use Moose;
+
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Baz',
+ default => sub { Baz->new },
+ handles => qr/.*/
+ );
+
+ package Baz::Proxy2;
+ use strict;
+ use warnings;
+ use Moose;
+
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Baz',
+ default => sub { Baz->new },
+ handles => qr/.oo/
+ );
+
+ package Baz::Proxy3;
+ use strict;
+ use warnings;
+ use Moose;
+
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Baz',
+ default => sub { Baz->new },
+ handles => qr/b.*/
+ );
+}
+
+{
+ my $baz_proxy = Baz::Proxy1->new;
+ isa_ok($baz_proxy, 'Baz::Proxy1');
+
+ can_ok($baz_proxy, 'baz');
+ isa_ok($baz_proxy->baz, 'Baz');
+
+ can_ok($baz_proxy, 'foo');
+ can_ok($baz_proxy, 'bar');
+ can_ok($baz_proxy, 'boo');
+
+ is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
+ is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+}
+{
+ my $baz_proxy = Baz::Proxy2->new;
+ isa_ok($baz_proxy, 'Baz::Proxy2');
+
+ can_ok($baz_proxy, 'baz');
+ isa_ok($baz_proxy->baz, 'Baz');
+
+ can_ok($baz_proxy, 'foo');
+ can_ok($baz_proxy, 'boo');
+
+ is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+}
+{
+ my $baz_proxy = Baz::Proxy3->new;
+ isa_ok($baz_proxy, 'Baz::Proxy3');
+
+ can_ok($baz_proxy, 'baz');
+ isa_ok($baz_proxy->baz, 'Baz');
+
+ can_ok($baz_proxy, 'bar');
+ can_ok($baz_proxy, 'boo');
+
+ is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+}
+
+
::lives_ok {
has child_b => (
+ is => 'ro',
default => sub { ChildB->new },
handles => [qw/child_b_method_1/],
);
isa => "ChildE",
is => "ro",
default => sub { ChildE->new },
- handles => "child_e_method_2",
+ handles => ["child_e_method_2"],
);
} "can delegate to non moose class using explicit method list";
default => sub { ChildF->new },
handles => sub {
$delegate_class = $_[1]->name;
+ return;
},
);
} "subrefs on non moose class give no meta";
isa_ok( my $p = Parent->new, "Parent" );
isa_ok( $p->child_a, "ChildA" );
-ok( !$p->can("child_b"), "no child b accessor" );
+isa_ok( $p->child_b, "ChildB" );
isa_ok( $p->child_c, "ChildC" );
isa_ok( $p->child_d, "ChildD" );
isa_ok( $p->child_e, "ChildE" );
projects / gitmo/Moose.git / commitdiff