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 has_meta('Document');
114 has_meta('TPSReport');
116 no_droppings('Document');
117 no_droppings('Report');
118 no_droppings('TPSReport');
120 has_ro_attr( 'Document', $_ ) for qw( title author );
121 has_ro_attr( 'Report', 'summary' );
122 has_ro_attr( 'TPSReport', $_ ) for qw( t p s );
124 has_method( 'Document', 'output' );
125 has_augmented_method( 'Report', 'output' );
126 has_augmented_method( 'TPSReport', 'output' );
129 my $tps = TPSReport->new(
130 title => 'That TPS Report',
131 author => 'Peter Gibbons (for Bill Lumberg)',
132 summary => 'I celebrate his whole collection!',
133 t => 'PC Load Letter',
138 my $output = $tps->output;
139 $output =~ s/\n\n+/\n/g;
141 is( $output, <<'EOF', 'output returns expected report' );
143 I celebrate his whole collection!
147 Written by Peter Gibbons (for Bill Lumberg)
153 local $Test::Builder::Level = $Test::Builder::Level + 1;
156 has_meta('Employee');
157 no_droppings('Employee');
160 for my $attr_name ( qw( first_name last_name title ) ) {
161 my $attr = Person->meta->get_attribute($attr_name);
163 ok( $attr->has_type_constraint,
164 "Person $attr_name has a type constraint" );
165 is( $attr->type_constraint->name, 'Str',
166 "Person $attr_name type is Str" );
170 my $salary_level_attr = Employee->meta->get_attribute('salary_level');
171 ok( $salary_level_attr->has_type_constraint,
172 'Employee salary_level has a type constraint' );
174 my $tc = $salary_level_attr->type_constraint;
176 for my $invalid ( 0, 11, -14, 'foo', undef ) {
177 my $str = defined $invalid ? $invalid : 'undef';
178 ok( ! $tc->check($invalid),
179 "salary_level type rejects invalid value - $str" );
182 for my $valid ( 1..10 ) {
183 ok( $tc->check($valid),
184 "salary_level type accepts valid value - $valid" );
189 my $salary_attr = Employee->meta->get_attribute('salary');
191 ok( $salary_attr->has_type_constraint,
192 'Employee salary has a type constraint' );
194 my $tc = $salary_attr->type_constraint;
196 for my $invalid ( 0, -14, 'foo', undef ) {
197 my $str = defined $invalid ? $invalid : 'undef';
198 ok( ! $tc->check($invalid),
199 "salary type rejects invalid value - $str" );
202 for my $valid ( 1, 100_000, 10**10 ) {
203 ok( $tc->check($valid),
204 "salary type accepts valid value - $valid" );
209 my $ssn_attr = Employee->meta->get_attribute('ssn');
211 ok( $ssn_attr->has_type_constraint,
212 'Employee ssn has a type constraint' );
214 my $tc = $ssn_attr->type_constraint;
216 for my $invalid ( 0, -14, 'foo', undef, '123-ab-1241', '123456789' ) {
217 my $str = defined $invalid ? $invalid : 'undef';
218 ok( ! $tc->check($invalid),
219 "ssn type rejects invalid value - $str" );
222 for my $valid ( '041-12-1251', '123-45-6789', '926-41-5820' ) {
223 ok( $tc->check($valid),
224 "ssn type accepts valid value - $valid" );
231 local $Test::Builder::Level = $Test::Builder::Level + 1;
233 has_meta('BankAccount');
234 no_droppings('BankAccount');
236 has_rw_attr( 'BankAccount', 'balance' );
237 has_rw_attr( 'BankAccount', 'owner' );
238 has_ro_attr( 'BankAccount', 'history' );
241 my $person_meta = Person->meta;
242 ok( ! $person_meta->has_attribute('balance'),
243 'Person class does not have a balance attribute' );
245 my $deposit_meth = $person_meta->get_method('deposit');
246 isa_ok( $deposit_meth, 'Moose::Meta::Method::Delegation' );
248 my $withdraw_meth = $person_meta->get_method('withdraw');
249 isa_ok( $withdraw_meth, 'Moose::Meta::Method::Delegation' );
251 my $ba_meta = BankAccount->meta;
252 ok( $ba_meta->get_attribute('owner')->is_weak_ref,
253 'owner attribute is a weak ref' );
262 ok( $class->can('meta'), "$class has a meta() method" )
263 or BAIL_OUT("Cannot run tests against a class without a meta! (Did you forget to 'use Moose'?)");
270 my @isa = $class->meta->linearized_isa;
271 shift @isa; # returns $class as the first entry
273 my $count = scalar @{$parents};
274 my $noun = PL_N( 'parent', $count );
276 is( scalar @isa, $count, "$class has $count $noun" );
278 for ( my $i = 0; $i < @{$parents}; $i++ ) {
279 is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" );
287 my $noun = PL_N( 'attribute', $count );
288 is( scalar $class->meta->get_attribute_list, $count,
289 "$class defines $count $noun" );
296 my $articled = A($name);
297 ok( $class->meta->has_attribute($name),
298 "$class has $articled attribute" );
300 my $attr = $class->meta->get_attribute($name);
302 is( $attr->get_read_method, $name,
303 "$name attribute has a reader accessor - $name()" );
304 is( $attr->get_write_method, $name,
305 "$name attribute has a writer accessor - $name()" );
312 my $articled = A($name);
313 ok( $class->meta->has_attribute($name),
314 "$class has $articled attribute" );
316 my $attr = $class->meta->get_attribute($name);
318 is( $attr->get_read_method, $name,
319 "$name attribute has a reader accessor - $name()" );
320 is( $attr->get_write_method, undef,
321 "$name attribute does not have a writer" );
328 my $articled = A($name);
329 ok( $class->meta->has_method($name), "$class has $articled method" );
332 sub has_overridden_method {
336 my $articled = A($name);
337 ok( $class->meta->has_method($name), "$class has $articled method" );
339 my $meth = $class->meta->get_method($name);
340 isa_ok( $meth, 'Moose::Meta::Method::Overridden' );
343 sub has_augmented_method {
347 my $articled = A($name);
348 ok( $class->meta->has_method($name), "$class has $articled method" );
350 my $meth = $class->meta->get_method($name);
351 isa_ok( $meth, 'Moose::Meta::Method::Augmented' );
357 ok( !$class->can('has'), "no Moose droppings in $class" );
358 ok( !$class->can('subtype'), "no Moose::Util::TypeConstraints droppings in $class" );
364 ok( $class->meta->is_immutable, "$class has been made immutable" );
371 ok( $class->meta->does_role($role), "$class does the $role role" );
375 my $person = Person->new(
376 first_name => 'Bilbo',
377 last_name => 'Baggins',
380 is( $person->full_name, 'Bilbo Baggins',
381 'full_name() is correctly implemented' );
383 $person = Person->new( [ qw( Lisa Smith ) ] );
384 is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' );
385 is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' );
387 eval { Person->new( sub { 'foo' } ) };
388 like( $@, qr/\QSingle parameters to new() must be a HASH ref/,
389 'Person constructor still rejects bad parameters' );
393 my $employee = Employee->new(
394 first_name => 'Amanda',
395 last_name => 'Palmer',
400 my $orig_super = \&Employee::super;
401 no warnings 'redefine';
402 local *Employee::super = sub { $called++; goto &$orig_super };
404 is( $employee->full_name, 'Amanda Palmer (Singer)',
405 'full_name() is properly overriden in Employee' );
406 ok( $called, 'Employee->full_name calls super()' );
410 my $person = Person->new(
411 first_name => 'Bilbo',
412 last_name => 'Baggins',
416 is( $person->as_string, 'Bilbo Baggins',
417 'as_string() is correctly implemented' );
419 account_tests($person);
423 my $employee = Employee->new(
424 first_name => 'Amanda',
425 last_name => 'Palmer',
430 is( $employee->as_string, 'Amanda Palmer (Singer)',
431 'as_string() uses overridden full_name method in Employee' );
433 account_tests($employee);
437 my $person = Person->new(
438 first_name => 'Bilbo',
439 last_name => 'Baggins',
442 is( $person->full_name, 'Bilbo Baggins',
443 'full_name() is correctly implemented for a Person without a title' );
444 ok( !$person->has_title,
445 'Person has_title predicate is working correctly (returns false)' );
447 $person->title('Ringbearer');
448 ok( $person->has_title, 'Person has_title predicate is working correctly (returns true)' );
451 my $orig_pred = \&Person::has_title;
452 no warnings 'redefine';
453 local *Person::has_title = sub { $called++; goto &$orig_pred };
455 is( $person->full_name, 'Bilbo Baggins (Ringbearer)',
456 'full_name() is correctly implemented for a Person with a title' );
457 ok( $called, 'full_name in person uses the predicate for the title attribute' );
459 $person->clear_title;
460 ok( !$person->has_title, 'Person clear_title method cleared the title' );
462 account_tests( $person, 100 );
466 my $employee = Employee->new(
467 first_name => 'Jimmy',
473 is( $employee->salary, 30000,
474 'salary is calculated from salary_level, and salary passed to constructor is ignored' );
478 my $person = Person->new(
479 first_name => 'Bilbo',
480 last_name => 'Baggins',
483 isa_ok( $person->account, 'BankAccount' );
484 is( $person->account->owner, $person,
485 'owner of bank account is person that created account' );
487 $person->deposit(10);
488 is_deeply( $person->account->history, [ 100, 10 ],
489 'deposit was recorded in account history' );
491 $person->withdraw(15);
492 is_deeply( $person->account->history, [ 100, 10, -15 ],
493 'withdrawal was recorded in account history' );
497 local $Test::Builder::Level = $Test::Builder::Level + 1;
500 my $base_amount = shift || 0;
502 $person->deposit(50);
503 eval { $person->withdraw( 75 + $base_amount ) };
504 like( $@, qr/\QBalance cannot be negative/,
505 'cannot withdraw more than is in our balance' );
507 $person->withdraw( 23 );
509 is( $person->balance, 27 + $base_amount,
510 'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23' );