1 package MooseClass::Tests;
6 use Lingua::EN::Inflect qw( A PL_N );
7 use Test::More 'no_plan';
11 person_attr_count => 2,
12 employee_attr_count => 3,
16 local $Test::Builder::Level = $Test::Builder::Level + 1;
20 check_isa( 'Person', ['Moose::Object'] );
22 count_attrs( 'Person', $p{person_attr_count} );
24 has_rw_attr( 'Person', $_ ) for qw( first_name last_name );
26 has_method( 'Person', 'full_name' );
28 no_droppings('Person');
29 is_immutable('Person');
35 check_isa( 'Employee', [ 'Person', 'Moose::Object' ] );
37 count_attrs( 'Employee', $p{employee_attr_count} );
39 has_rw_attr( 'Employee', $_ ) for qw( title salary );
40 has_ro_attr( 'Employee', 'ssn' );
42 has_overridden_method( 'Employee', 'full_name' );
48 tests01( person_attr_count => 3, @_ );
50 local $Test::Builder::Level = $Test::Builder::Level + 1;
52 no_droppings($_) for qw( Printable HasAccount );
54 does_role( 'Person', $_ ) for qw( Printable HasAccount );
55 has_method( 'Person', $_ ) for qw( as_string deposit withdraw );
56 has_rw_attr( 'Person', 'balance' );
58 does_role( 'Employee', $_ ) for qw( Printable HasAccount );
66 local $Test::Builder::Level = $Test::Builder::Level + 1;
71 has_rw_attr( 'Person', 'title' );
73 has_rw_attr( 'Employee', 'title' );
74 has_rw_attr( 'Employee', 'salary_level' );
75 has_ro_attr( 'Employee', 'salary' );
77 has_method( 'Employee', '_build_salary' );
80 ok( ! Employee->meta->has_method('full_name'),
81 'Employee no longer implements a full_name method' );
83 my $person_title_attr = Person->meta->get_attribute('title');
84 ok( !$person_title_attr->is_required, 'title is not required in Person' );
85 is( $person_title_attr->predicate, 'has_title',
86 'Person title attr has a has_title predicate' );
87 is( $person_title_attr->clearer, 'clear_title',
88 'Person title attr has a clear_title clearer' );
90 my $balance_attr = Person->meta->get_attribute('balance');
91 is( $balance_attr->default, 100, 'balance defaults to 100' );
93 my $employee_title_attr = Employee->meta->get_attribute('title');
94 is( $employee_title_attr->default, 'Worker',
95 'title defaults to Worker in Employee' );
97 my $salary_level_attr = Employee->meta->get_attribute('salary_level');
98 is( $salary_level_attr->default, 1, 'salary_level defaults to 1' );
100 my $salary_attr = Employee->meta->get_attribute('salary');
101 ok( !$salary_attr->init_arg, 'no init_arg for salary attribute' );
102 ok( $salary_attr->has_builder, 'salary attr has a builder' );
110 local $Test::Builder::Level = $Test::Builder::Level + 1;
112 no_droppings('OutputsXML');
114 does_role( 'Person', 'OutputsXML' );
117 ok( scalar OutputsXML->meta->get_around_method_modifiers('as_xml'),
118 'OutputsXML has an around modifier for as_xml' );
120 isa_ok( Employee->meta->get_method('as_xml'),
121 'Moose::Meta::Method::Augmented', 'as_xml is augmented in Employee' );
129 local $Test::Builder::Level = $Test::Builder::Level + 1;
131 has_meta('BankAccount');
132 no_droppings('BankAccount');
134 has_rw_attr( 'BankAccount', 'balance' );
135 has_rw_attr( 'BankAccount', 'owner' );
136 has_ro_attr( 'BankAccount', 'history' );
139 my $person_meta = Person->meta;
140 ok( ! $person_meta->has_attribute('balance'),
141 'Person class does not have a balance attribute' );
143 my $deposit_meth = $person_meta->get_method('deposit');
144 isa_ok( $deposit_meth, 'Moose::Meta::Method::Delegation' );
146 my $withdraw_meth = $person_meta->get_method('withdraw');
147 isa_ok( $withdraw_meth, 'Moose::Meta::Method::Delegation' );
149 my $ba_meta = BankAccount->meta;
150 ok( $ba_meta->get_attribute('owner')->is_weak_ref,
151 'owner attribute is a weak ref' );
160 ok( $class->can('meta'), "$class has a meta() method" )
161 or BAIL_OUT("Cannot run tests against a class without a meta!");
168 my @isa = $class->meta->linearized_isa;
169 shift @isa; # returns $class as the first entry
171 my $count = scalar @{$parents};
172 my $noun = PL_N( 'parent', $count );
174 is( scalar @isa, $count, "$class has $count $noun" );
176 for ( my $i = 0; $i < @{$parents}; $i++ ) {
177 is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" );
185 my $noun = PL_N( 'attribute', $count );
186 is( scalar $class->meta->get_attribute_list, $count,
187 "$class defines $count $noun" );
194 my $articled = A($name);
195 ok( $class->meta->has_attribute($name),
196 "$class has $articled attribute" );
198 my $attr = $class->meta->get_attribute($name);
200 is( $attr->get_read_method, $name,
201 "$name attribute has a reader accessor - $name()" );
202 is( $attr->get_write_method, $name,
203 "$name attribute has a writer accessor - $name()" );
210 my $articled = A($name);
211 ok( $class->meta->has_attribute($name),
212 "$class has $articled attribute" );
214 my $attr = $class->meta->get_attribute($name);
216 is( $attr->get_read_method, $name,
217 "$name attribute has a reader accessor - $name()" );
218 is( $attr->get_write_method, undef,
219 "$name attribute does not have a writer" );
226 my $articled = A($name);
227 ok( $class->meta->has_method($name), "$class has $articled method" );
230 sub has_overridden_method {
234 my $articled = A($name);
235 ok( $class->meta->has_method($name), "$class has $articled method" );
237 my $meth = $class->meta->get_method($name);
238 isa_ok( $meth, 'Moose::Meta::Method::Overridden' );
244 ok( !$class->can('has'), "no Moose droppings in $class" );
250 ok( $class->meta->is_immutable, "$class has been made immutable" );
257 ok( $class->meta->does_role($role), "$class does the $role role" );
261 my $person = Person->new(
262 first_name => 'Bilbo',
263 last_name => 'Baggins',
266 is( $person->full_name, 'Bilbo Baggins',
267 'full_name() is correctly implemented' );
269 $person = Person->new( [ qw( Lisa Smith ) ] );
270 is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' );
271 is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' );
273 eval { Person->new( sub { 'foo' } ) };
274 like( $@, qr/\QSingle parameters to new() must be a HASH ref/,
275 'Person constructor still rejects bad parameters' );
279 my $employee = Employee->new(
280 first_name => 'Amanda',
281 last_name => 'Palmer',
285 is( $employee->full_name, 'Amanda Palmer (Singer)', 'full_name() is properly overriden in Employee' );
289 my $person = Person->new(
290 first_name => 'Bilbo',
291 last_name => 'Baggins',
295 is( $person->as_string, 'Bilbo Baggins',
296 'as_string() is correctly implemented' );
298 account_tests($person);
302 my $employee = Employee->new(
303 first_name => 'Amanda',
304 last_name => 'Palmer',
309 is( $employee->as_string, 'Amanda Palmer (Singer)',
310 'as_string() uses overridden full_name method in Employee' );
312 account_tests($employee);
316 my $person = Person->new(
317 first_name => 'Bilbo',
318 last_name => 'Baggins',
321 is( $person->full_name, 'Bilbo Baggins',
322 'full_name() is correctly implemented for a Person without a title' );
323 ok( !$person->has_title,
324 'Person has_title predicate is working correctly' );
326 $person->title('Ringbearer');
327 ok( $person->has_title, 'Person has_title predicate is working correctly' );
328 is( $person->full_name, 'Bilbo Baggins (Ringbearer)',
329 'full_name() is correctly implemented for a Person with a title' );
331 $person->clear_title;
332 ok( !$person->has_title, 'Person clear_title method cleared the title' );
334 account_tests( $person, 100 );
338 my $employee = Employee->new(
339 first_name => 'Jimmy',
345 is( $employee->salary, 30000,
346 'salary is calculated from salary_level, and salary passed to constructor is ignored' );
351 my $person = Person->new(
352 first_name => 'Bilbo',
353 last_name => 'Baggins',
357 <?xml version="1.0" encoding="UTF-8"?>
359 <first_name>Bilbo</first_name>
360 <last_name>Baggins</last_name>
365 is( $person->as_xml, $xml, 'Person outputs expected XML' );
369 my $employee = Employee->new(
370 first_name => 'Jimmy',
372 ssn => '123-99-4567',
377 <?xml version="1.0" encoding="UTF-8"?>
379 <first_name>Jimmy</first_name>
380 <last_name>Foo</last_name>
381 <title>Worker</title>
382 <salary>30000</salary>
383 <salary_level>3</salary_level>
384 <ssn>123-99-4567</ssn>
388 is( $employee->as_xml, $xml, 'Employee outputs expected XML' );
392 my $person = Person->new(
393 first_name => 'Bilbo',
394 last_name => 'Baggins',
397 isa_ok( $person->account, 'BankAccount' );
398 is( $person->account->owner, $person,
399 'owner of bank account is person that created account' );
401 $person->deposit(10);
402 is_deeply( $person->account->history, [ 100, 10 ],
403 'deposit was recorded in account history' );
405 $person->withdraw(15);
406 is_deeply( $person->account->history, [ 100, 10, -15 ],
407 'withdrawal was recorded in account history' );
411 local $Test::Builder::Level = $Test::Builder::Level + 1;
414 my $base_amount = shift || 0;
416 $person->deposit(50);
417 eval { $person->withdraw( 75 + $base_amount ) };
418 like( $@, qr/\QBalance cannot be negative/,
419 'cannot withdraw more than is in our balance' );
421 $person->withdraw( 23 );
423 is( $person->balance, 27 + $base_amount,
424 'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23' );