Commit | Line | Data |
ddd87d75 |
1 | package MooseClass::Tests; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
5cab7e05 |
6 | use Lingua::EN::Inflect qw( A PL_N ); |
ddd87d75 |
7 | use Test::More 'no_plan'; |
8 | |
9 | sub tests01 { |
5cab7e05 |
10 | my %p = ( |
11 | person_attr_count => 2, |
12 | employee_attr_count => 3, |
13 | @_, |
14 | ); |
15 | |
ddd87d75 |
16 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
17 | |
18 | has_meta('Person'); |
19 | |
20 | check_isa( 'Person', ['Moose::Object'] ); |
21 | |
5cab7e05 |
22 | count_attrs( 'Person', $p{person_attr_count} ); |
ddd87d75 |
23 | |
24 | has_rw_attr( 'Person', $_ ) for qw( first_name last_name ); |
25 | |
26 | has_method( 'Person', 'full_name' ); |
27 | |
28 | no_droppings('Person'); |
29 | is_immutable('Person'); |
30 | |
31 | person01(); |
32 | |
33 | has_meta('Employee'); |
34 | |
35 | check_isa( 'Employee', [ 'Person', 'Moose::Object' ] ); |
36 | |
5cab7e05 |
37 | count_attrs( 'Employee', $p{employee_attr_count} ); |
ddd87d75 |
38 | |
39 | has_rw_attr( 'Employee', $_ ) for qw( position salary ); |
40 | has_ro_attr( 'Employee', 'ssn' ); |
41 | |
42 | has_overridden_method( 'Employee', 'full_name' ); |
43 | |
44 | employee01(); |
45 | } |
46 | |
5cab7e05 |
47 | sub tests02 { |
48 | tests01( person_attr_count => 3 ); |
49 | |
50 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
51 | |
52 | no_droppings($_) for qw( Printable HasAccount ); |
53 | |
54 | does_role( 'Person', $_ ) for qw( Printable HasAccount ); |
55 | has_method( 'Person', $_ ) for qw( as_string deposit withdraw ); |
56 | has_rw_attr( 'Person', 'balance' ); |
57 | |
58 | does_role( 'Employee', $_ ) for qw( Printable HasAccount ); |
59 | |
60 | person02(); |
61 | employee02(); |
62 | } |
63 | |
ddd87d75 |
64 | sub has_meta { |
65 | my $class = shift; |
66 | |
67 | ok( $class->can('meta'), "$class has a meta() method" ) |
68 | or BAIL_OUT("Cannot run tests against a class without a meta!"); |
69 | } |
70 | |
71 | sub check_isa { |
72 | my $class = shift; |
73 | my $parents = shift; |
74 | |
75 | my @isa = $class->meta->linearized_isa; |
76 | shift @isa; # returns $class as the first entry |
77 | |
78 | my $count = scalar @{$parents}; |
79 | my $noun = PL_N( 'parent', $count ); |
80 | |
81 | is( scalar @isa, $count, "$class has $count $noun" ); |
82 | |
83 | for ( my $i = 0; $i < @{$parents}; $i++ ) { |
84 | is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" ); |
85 | } |
86 | } |
87 | |
88 | sub count_attrs { |
89 | my $class = shift; |
90 | my $count = shift; |
91 | |
92 | my $noun = PL_N( 'attribute', $count ); |
5cab7e05 |
93 | is( |
94 | scalar $class->meta->get_attribute_list, $count, |
95 | "$class defines $count $noun" |
96 | ); |
ddd87d75 |
97 | } |
98 | |
99 | sub has_rw_attr { |
100 | my $class = shift; |
101 | my $name = shift; |
102 | |
5cab7e05 |
103 | my $article = A($name); |
104 | ok( $class->meta->has_attribute($name), |
105 | "$class has $article $name attribute" ); |
ddd87d75 |
106 | |
107 | my $attr = $class->meta->get_attribute($name); |
108 | |
5cab7e05 |
109 | is( |
110 | $attr->get_read_method, $name, |
111 | "$name attribute has a reader accessor - $name()" |
112 | ); |
113 | is( |
114 | $attr->get_write_method, $name, |
115 | "$name attribute has a writer accessor - $name()" |
116 | ); |
ddd87d75 |
117 | } |
118 | |
119 | sub has_ro_attr { |
120 | my $class = shift; |
121 | my $name = shift; |
122 | |
5cab7e05 |
123 | my $article = A($name); |
124 | ok( $class->meta->has_attribute($name), |
125 | "$class has $article $name attribute" ); |
ddd87d75 |
126 | |
127 | my $attr = $class->meta->get_attribute($name); |
128 | |
5cab7e05 |
129 | is( |
130 | $attr->get_read_method, $name, |
131 | "$name attribute has a reader accessor - $name()" |
132 | ); |
133 | is( |
134 | $attr->get_write_method, undef, |
135 | "$name attribute does not have a writer" |
136 | ); |
ddd87d75 |
137 | } |
138 | |
139 | sub has_method { |
140 | my $class = shift; |
141 | my $name = shift; |
142 | |
5cab7e05 |
143 | my $article = A($name); |
144 | ok( $class->meta->has_method($name), "$class has $article $name method" ); |
ddd87d75 |
145 | } |
146 | |
147 | sub has_overridden_method { |
148 | my $class = shift; |
149 | my $name = shift; |
150 | |
5cab7e05 |
151 | my $article = A($name); |
152 | ok( $class->meta->has_method($name), "$class has $article $name method" ); |
ddd87d75 |
153 | |
154 | my $meth = $class->meta->get_method($name); |
155 | isa_ok( $meth, 'Moose::Meta::Method::Overridden' ); |
156 | } |
157 | |
158 | sub no_droppings { |
159 | my $class = shift; |
160 | |
161 | ok( !$class->can('has'), "no Moose droppings in $class" ); |
162 | } |
163 | |
164 | sub is_immutable { |
165 | my $class = shift; |
166 | |
167 | ok( $class->meta->is_immutable, "$class has been made immutable" ); |
168 | } |
169 | |
5cab7e05 |
170 | sub does_role { |
171 | my $class = shift; |
172 | my $role = shift; |
173 | |
174 | ok( $class->meta->does_role($role), "$class does the $role role" ); |
175 | } |
176 | |
ddd87d75 |
177 | sub person01 { |
178 | my $person = Person->new( |
179 | first_name => 'Bilbo', |
180 | last_name => 'Baggins', |
181 | ); |
182 | |
5cab7e05 |
183 | is( |
184 | $person->full_name, 'Bilbo Baggins', |
185 | 'full_name() is correctly implemented' |
186 | ); |
ddd87d75 |
187 | } |
188 | |
189 | sub employee01 { |
190 | my $employee = Employee->new( |
191 | first_name => 'Amanda', |
192 | last_name => 'Palmer', |
193 | position => 'Singer', |
194 | ); |
195 | |
5cab7e05 |
196 | is( |
197 | $employee->full_name, 'Amanda Palmer (Singer)', |
198 | 'full_name() is properly overriden in Employee' |
199 | ); |
ddd87d75 |
200 | } |
201 | |
5cab7e05 |
202 | sub person02 { |
203 | my $person = Person->new( |
204 | first_name => 'Bilbo', |
205 | last_name => 'Baggins', |
206 | balance => 0, |
207 | ); |
208 | |
209 | is( |
210 | $person->as_string, 'Bilbo Baggins', |
211 | 'as-string() is correctly implemented' |
212 | ); |
213 | |
214 | account_tests($person); |
215 | } |
216 | |
217 | sub employee02 { |
218 | my $employee = Employee->new( |
219 | first_name => 'Amanda', |
220 | last_name => 'Palmer', |
221 | position => 'Singer', |
222 | balance => 0, |
223 | ); |
224 | |
225 | is( |
226 | $employee->as_string, 'Amanda Palmer (Singer)', |
227 | 'as_string() uses overridden full_name method in Employee' |
228 | ); |
229 | |
230 | account_tests($employee); |
231 | } |
232 | |
233 | sub account_tests { |
234 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
235 | |
236 | my $person = shift; |
237 | |
238 | $person->deposit(50); |
239 | eval { $person->withdraw(75) }; |
240 | like( |
241 | $@, qr/\QBalance cannot be negative/, |
242 | 'cannot withdraw more than is in our balance' |
243 | ); |
244 | |
245 | $person->withdraw(23); |
246 | |
247 | is( $person->balance, 27, |
248 | 'balance is 25 after deposit of 50 and withdrawal of 23' ); |
249 | } |
ddd87d75 |
250 | |
251 | 1; |