Commit | Line | Data |
54b1cdf0 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
4e848edb |
6 | use Test::More tests => 35; |
54b1cdf0 |
7 | use Test::Exception; |
8 | |
9 | { |
10 | |
11 | package ChildASuper; |
12 | use Moose; |
13 | |
14 | sub child_a_super_method { "as" } |
15 | |
16 | package ChildA; |
17 | use Moose; |
18 | |
19 | extends "ChildASuper"; |
20 | |
21 | sub child_a_method_1 { "a1" } |
22 | sub child_a_method_2 { Scalar::Util::blessed($_[0]) . " a2" } |
23 | |
24 | package ChildASub; |
25 | use Moose; |
26 | |
27 | extends "ChildA"; |
28 | |
29 | sub child_a_method_3 { "a3" } |
30 | |
31 | package ChildB; |
32 | use Moose; |
33 | |
34 | sub child_b_method_1 { "b1" } |
35 | sub child_b_method_2 { "b2" } |
36 | sub child_b_method_3 { "b3" } |
37 | |
38 | package ChildC; |
39 | use Moose; |
40 | |
41 | sub child_c_method_1 { "c1" } |
42 | sub child_c_method_2 { "c2" } |
43 | sub child_c_method_3_la { "c3" } |
44 | sub child_c_method_4_la { "c4" } |
45 | |
46 | package ChildD; |
47 | use Moose; |
48 | |
49 | sub child_d_method_1 { "d1" } |
50 | sub child_d_method_2 { "d2" } |
51 | |
52 | package ChildE; |
53 | # no Moose |
54 | |
55 | sub new { bless {}, shift } |
56 | sub child_e_method_1 { "e1" } |
57 | sub child_e_method_2 { "e2" } |
58 | |
59 | package ChildF; |
60 | # no Moose |
61 | |
62 | sub new { bless {}, shift } |
63 | sub child_f_method_1 { "f1" } |
64 | sub child_f_method_2 { "f2" } |
65 | |
66 | package Parent; |
67 | use Moose; |
68 | |
69 | ::dies_ok { |
70 | has child_a => ( |
71 | is => "ro", |
72 | default => sub { ChildA->new }, |
98aae381 |
73 | handles => qr/.*/, |
54b1cdf0 |
74 | ); |
75 | } "all_methods requires explicit isa"; |
76 | |
77 | ::lives_ok { |
78 | has child_a => ( |
79 | isa => "ChildA", |
80 | is => "ro", |
81 | default => sub { ChildA->new }, |
98aae381 |
82 | handles => qr/.*/, |
54b1cdf0 |
83 | ); |
84 | } "allow all_methods with explicit isa"; |
85 | |
86 | ::lives_ok { |
87 | has child_b => ( |
452bac1b |
88 | is => 'ro', |
54b1cdf0 |
89 | default => sub { ChildB->new }, |
90 | handles => [qw/child_b_method_1/], |
91 | ); |
92 | } "don't need to declare isa if method list is predefined"; |
93 | |
94 | ::lives_ok { |
95 | has child_c => ( |
96 | isa => "ChildC", |
97 | is => "ro", |
98 | default => sub { ChildC->new }, |
99 | handles => qr/_la$/, |
100 | ); |
101 | } "can declare regex collector"; |
102 | |
103 | ::dies_ok { |
104 | has child_d => ( |
105 | is => "ro", |
106 | default => sub { ChildD->new }, |
107 | handles => sub { |
108 | my ( $class, $delegate_class ) = @_; |
109 | } |
110 | ); |
111 | } "can't create attr with generative handles parameter and no isa"; |
112 | |
113 | ::lives_ok { |
114 | has child_d => ( |
115 | isa => "ChildD", |
116 | is => "ro", |
117 | default => sub { ChildD->new }, |
118 | handles => sub { |
119 | my ( $class, $delegate_class ) = @_; |
120 | return; |
121 | } |
122 | ); |
123 | } "can't create attr with generative handles parameter and no isa"; |
124 | |
125 | ::lives_ok { |
126 | has child_e => ( |
127 | isa => "ChildE", |
128 | is => "ro", |
129 | default => sub { ChildE->new }, |
452bac1b |
130 | handles => ["child_e_method_2"], |
54b1cdf0 |
131 | ); |
132 | } "can delegate to non moose class using explicit method list"; |
133 | |
aff2941e |
134 | my $delegate_class; |
135 | ::lives_ok { |
136 | has child_f => ( |
137 | isa => "ChildF", |
138 | is => "ro", |
139 | default => sub { ChildF->new }, |
140 | handles => sub { |
4e848edb |
141 | $delegate_class = $_[1]->name; |
452bac1b |
142 | return; |
aff2941e |
143 | }, |
144 | ); |
145 | } "subrefs on non moose class give no meta"; |
146 | |
147 | ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" ); |
54b1cdf0 |
148 | |
149 | sub parent_method { "p" } |
150 | } |
151 | |
152 | # sanity |
153 | |
154 | isa_ok( my $p = Parent->new, "Parent" ); |
155 | isa_ok( $p->child_a, "ChildA" ); |
452bac1b |
156 | isa_ok( $p->child_b, "ChildB" ); |
54b1cdf0 |
157 | isa_ok( $p->child_c, "ChildC" ); |
158 | isa_ok( $p->child_d, "ChildD" ); |
159 | isa_ok( $p->child_e, "ChildE" ); |
aff2941e |
160 | isa_ok( $p->child_f, "ChildF" ); |
54b1cdf0 |
161 | |
54b1cdf0 |
162 | |
163 | is( $p->parent_method, "p", "parent method" ); |
164 | is( $p->child_a->child_a_super_method, "as", "child supermethod" ); |
165 | is( $p->child_a->child_a_method_1, "a1", "child method" ); |
166 | |
167 | can_ok( $p, "child_a_super_method" ); |
168 | can_ok( $p, "child_a_method_1" ); |
169 | can_ok( $p, "child_a_method_2" ); |
170 | ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" ); |
171 | |
172 | is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" ); |
173 | is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" ); |
174 | |
175 | |
176 | can_ok( $p, "child_b_method_1" ); |
177 | ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" ); |
178 | |
179 | |
180 | ok( !$p->can($_), "none of ChildD's methods ($_)" ) |
181 | for grep { /^child/ } map { $_->{name} } ChildD->meta->compute_all_applicable_methods(); |
182 | |
183 | can_ok( $p, "child_c_method_3_la" ); |
184 | can_ok( $p, "child_c_method_4_la" ); |
185 | |
186 | is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" ); |
187 | |
188 | can_ok( $p, "child_e_method_2" ); |
189 | ok( !$p->can("child_e_method_1"), "but not child_e_method_1"); |
190 | |
191 | is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" ); |