From: Yuval Kogman <nothingmuch@woobling.org>
Date: Sun, 30 Apr 2006 12:46:01 +0000 (+0000)
Subject: Allow code refs to act on foreign classes for delegator generation
X-Git-Tag: 0_09_03~56
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=aff2941e02b025e6d529f6e8cf0624b609576783;p=gitmo%2FMoose.git

Allow code refs to act on foreign classes for delegator generation
---

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index f5d211a..f7a2252 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -142,6 +142,8 @@ sub generate_delegation_list {
     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";
@@ -156,20 +158,18 @@ sub _guess_attr_class_or_role {
     confess "Generative delegations must explicitly specify a class or a role for the attribute's type"
         unless $isa || $does;
 
-    # if it's a class/role name make it into a meta object
-    for (grep { defined && !ref($_) } $isa, $does) {
-        confess "Generative delegations must refer to Moose class/role types"
-            unless $_->can("meta");
-        $_ = $_->meta;
-    }
-
     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 && $does and !confess->does( $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");
+    }
 
     return $isa || $does;
 }
diff --git a/t/070_delegation.t b/t/070_delegation.t
index ab31491..be15852 100644
--- a/t/070_delegation.t
+++ b/t/070_delegation.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 34;
+use Test::More tests => 36;
 use Test::Exception;
 
 {
@@ -135,9 +135,23 @@ use Test::Exception;
             isa     => "ChildF",
             is      => "ro",
             default => sub { ChildF->new },
-            handles => sub { },
+            handles => qr/.*/,
         );
-    } "but not generative one";
+    } "can't use regexes on foreign classes";
+
+    my $delegate_class;
+    ::lives_ok {
+        has child_f => (
+            isa     => "ChildF",
+            is      => "ro",
+            default => sub { ChildF->new },
+            handles => sub {
+                $delegate_class = $_[1];
+            },
+        );
+    } "subrefs on non moose class give no meta";
+
+    ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" );
 
     sub parent_method { "p" }
 }
@@ -146,13 +160,12 @@ use Test::Exception;
 
 isa_ok( my $p = Parent->new, "Parent" );
 isa_ok( $p->child_a, "ChildA" );
-#isa_ok( $p->child_b, "ChildB" ); # no accessor
+ok( !$p->can("child_b"), "no child b accessor" );
 isa_ok( $p->child_c, "ChildC" );
 isa_ok( $p->child_d, "ChildD" );
 isa_ok( $p->child_e, "ChildE" );
+isa_ok( $p->child_f, "ChildF" );
 
-ok( !$p->can("child_b"), "no child b accessor" );
-ok( !$p->can("child_f"), "no child f" );
 
 is( $p->parent_method, "p", "parent method" );
 is( $p->child_a->child_a_super_method, "as", "child supermethod" );