1 package MooseClass::Tests;
6 use Lingua::EN::Inflect qw( A PL_N );
7 use Test::More 'no_plan';
10 local $Test::Builder::Level = $Test::Builder::Level + 1;
14 check_isa( 'Person', ['Moose::Object'] );
16 has_rw_attr( 'Person', $_ ) for qw( first_name last_name );
18 has_method( 'Person', 'full_name' );
20 no_droppings('Person');
21 is_immutable('Person');
27 check_isa( 'Employee', [ 'Person', 'Moose::Object' ] );
29 has_rw_attr( 'Employee', $_ ) for qw( title salary );
30 has_ro_attr( 'Employee', 'ssn' );
32 has_overridden_method( 'Employee', 'full_name' );
40 local $Test::Builder::Level = $Test::Builder::Level + 1;
42 no_droppings($_) for qw( Printable HasAccount );
44 does_role( 'Person', $_ ) for qw( Printable HasAccount );
45 has_method( 'Person', $_ ) for qw( as_string deposit withdraw );
46 has_rw_attr( 'Person', 'balance' );
48 does_role( 'Employee', $_ ) for qw( Printable HasAccount );
56 local $Test::Builder::Level = $Test::Builder::Level + 1;
61 has_rw_attr( 'Person', 'title' );
63 has_rw_attr( 'Employee', 'title', 'overridden' );
64 has_rw_attr( 'Employee', 'salary_level' );
65 has_ro_attr( 'Employee', 'salary' );
67 has_method( 'Employee', '_build_salary' );
70 ok( ! Employee->meta->has_method('full_name'),
71 'Employee no longer implements a full_name method' );
73 my $person_title_attr = Person->meta->get_attribute('title');
74 ok( !$person_title_attr->is_required, 'title is not required in Person' );
75 is( $person_title_attr->predicate, 'has_title',
76 'Person title attr has a has_title predicate' );
77 is( $person_title_attr->clearer, 'clear_title',
78 'Person title attr has a clear_title clearer' );
80 my $balance_attr = Person->meta->get_attribute('balance');
81 is( $balance_attr->default, 100, 'balance defaults to 100' );
83 my $employee_title_attr = Employee->meta->get_attribute('title');
84 is( $employee_title_attr->default, 'Worker',
85 'title defaults to Worker in Employee' );
87 my $salary_level_attr = Employee->meta->get_attribute('salary_level');
88 is( $salary_level_attr->default, 1, 'salary_level defaults to 1' );
90 my $salary_attr = Employee->meta->get_attribute('salary');
91 ok( !$salary_attr->init_arg, 'no init_arg for salary attribute' );
92 ok( $salary_attr->has_builder, 'salary attr has a builder' );
100 local $Test::Builder::Level = $Test::Builder::Level + 1;
102 has_meta('Document');
104 has_meta('TPSReport');
106 no_droppings('Document');
107 no_droppings('Report');
108 no_droppings('TPSReport');
110 has_ro_attr( 'Document', $_ ) for qw( title author );
111 has_ro_attr( 'Report', 'summary' );
112 has_ro_attr( 'TPSReport', $_ ) for qw( t p s );
114 has_method( 'Document', 'output' );
115 has_augmented_method( 'Report', 'output' );
116 has_augmented_method( 'TPSReport', 'output' );
119 my $tps = TPSReport->new(
120 title => 'That TPS Report',
121 author => 'Peter Gibbons (for Bill Lumberg)',
122 summary => 'I celebrate his whole collection!',
123 t => 'PC Load Letter',
128 my $output = $tps->output;
129 $output =~ s/\n\n+/\n/g;
131 is( $output, <<'EOF', 'output returns expected report' );
133 I celebrate his whole collection!
137 Written by Peter Gibbons (for Bill Lumberg)
143 local $Test::Builder::Level = $Test::Builder::Level + 1;
146 has_meta('Employee');
147 no_droppings('Employee');
150 for my $attr_name ( qw( first_name last_name title ) ) {
151 my $attr = Person->meta->get_attribute($attr_name);
153 ok( $attr->has_type_constraint,
154 "Person $attr_name has a type constraint" );
155 is( $attr->type_constraint->name, 'Str',
156 "Person $attr_name type is Str" );
160 my $salary_level_attr = Employee->meta->get_attribute('salary_level');
161 ok( $salary_level_attr->has_type_constraint,
162 'Employee salary_level has a type constraint' );
164 my $tc = $salary_level_attr->type_constraint;
166 for my $invalid ( 0, 11, -14, 'foo', undef ) {
167 my $str = defined $invalid ? $invalid : 'undef';
168 ok( ! $tc->check($invalid),
169 "salary_level type rejects invalid value - $str" );
172 for my $valid ( 1..10 ) {
173 ok( $tc->check($valid),
174 "salary_level type accepts valid value - $valid" );
179 my $salary_attr = Employee->meta->get_attribute('salary');
181 ok( $salary_attr->has_type_constraint,
182 'Employee salary has a type constraint' );
184 my $tc = $salary_attr->type_constraint;
186 for my $invalid ( 0, -14, 'foo', undef ) {
187 my $str = defined $invalid ? $invalid : 'undef';
188 ok( ! $tc->check($invalid),
189 "salary type rejects invalid value - $str" );
192 for my $valid ( 1, 100_000, 10**10 ) {
193 ok( $tc->check($valid),
194 "salary type accepts valid value - $valid" );
199 my $ssn_attr = Employee->meta->get_attribute('ssn');
201 ok( $ssn_attr->has_type_constraint,
202 'Employee ssn has a type constraint' );
204 my $tc = $ssn_attr->type_constraint;
206 for my $invalid ( 0, -14, 'foo', undef, '123-ab-1241', '123456789' ) {
207 my $str = defined $invalid ? $invalid : 'undef';
208 ok( ! $tc->check($invalid),
209 "ssn type rejects invalid value - $str" );
212 for my $valid ( '041-12-1251', '123-45-6789', '926-41-5820' ) {
213 ok( $tc->check($valid),
214 "ssn type accepts valid value - $valid" );
221 local $Test::Builder::Level = $Test::Builder::Level + 1;
224 has_meta('Employee');
225 has_meta('BankAccount');
226 no_droppings('BankAccount');
228 has_rw_attr( 'BankAccount', 'balance' );
229 has_rw_attr( 'BankAccount', 'owner' );
230 has_ro_attr( 'BankAccount', 'history' );
233 my $ba_meta = BankAccount->meta;
234 ok( $ba_meta->has_attribute('balance'),
235 'BankAccount class has a balance attribute' );
237 my $history_attr = $ba_meta->get_attribute('history');
240 $history_attr->meta()
241 ->does_role('Moose::Meta::Attribute::Native::Trait::Array'),
242 'BankAccount history attribute uses native delegation to an array ref'
245 ok( $ba_meta->get_attribute('balance')->has_trigger,
246 'BankAccount balance attribute has a trigger' );
248 my $person_meta = Person->meta;
249 ok( ! $person_meta->has_attribute('balance'),
250 'Person class does not have a balance attribute' );
252 my $deposit_meth = $person_meta->get_method('deposit');
253 isa_ok( $deposit_meth, 'Moose::Meta::Method::Delegation' );
255 my $withdraw_meth = $person_meta->get_method('withdraw');
256 isa_ok( $withdraw_meth, 'Moose::Meta::Method::Delegation' );
258 ok( $ba_meta->get_attribute('owner')->is_weak_ref,
259 'owner attribute is a weak ref' );
269 or BAIL_OUT("$class cannot be loaded");
271 ok( $class->can('meta'), "$class has a meta() method" )
272 or BAIL_OUT("$class does not have a meta() method (did you forget to 'use Moose'?)");
279 my @isa = $class->meta->linearized_isa;
280 shift @isa; # returns $class as the first entry
282 my $count = scalar @{$parents};
283 my $noun = PL_N( 'parent', $count );
285 is( scalar @isa, $count, "$class has $count $noun" );
287 for ( my $i = 0; $i < @{$parents}; $i++ ) {
288 is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" );
295 my $overridden = shift;
297 my $articled = $overridden ? "an overridden $name" : A($name);
298 ok( $class->meta->has_attribute($name),
299 "$class has $articled attribute" );
301 my $attr = $class->meta->get_attribute($name);
303 is( $attr->get_read_method, $name,
304 "$name attribute has a reader accessor - $name()" );
305 is( $attr->get_write_method, $name,
306 "$name attribute has a writer accessor - $name()" );
313 my $articled = A($name);
314 ok( $class->meta->has_attribute($name),
315 "$class has $articled attribute" );
317 my $attr = $class->meta->get_attribute($name);
319 is( $attr->get_read_method, $name,
320 "$name attribute has a reader accessor - $name()" );
321 is( $attr->get_write_method, undef,
322 "$name attribute does not have a writer" );
329 my $articled = A($name);
330 ok( $class->meta->has_method($name), "$class has $articled method" );
333 sub has_overridden_method {
337 my $articled = A($name);
338 ok( $class->meta->has_method($name), "$class has $articled method" );
340 my $meth = $class->meta->get_method($name);
341 isa_ok( $meth, 'Moose::Meta::Method::Overridden' );
344 sub has_augmented_method {
348 my $articled = A($name);
349 ok( $class->meta->has_method($name), "$class has $articled method" );
351 my $meth = $class->meta->get_method($name);
352 isa_ok( $meth, 'Moose::Meta::Method::Augmented' );
358 ok( !$class->can('has'), "no Moose droppings in $class" );
359 ok( !$class->can('subtype'), "no Moose::Util::TypeConstraints droppings in $class" );
365 ok( $class->meta->is_immutable, "$class has been made immutable" );
372 ok( $class->meta->does_role($role), "$class does the $role role" );
376 my $person = Person->new(
377 first_name => 'Bilbo',
378 last_name => 'Baggins',
381 is( $person->full_name, 'Bilbo Baggins',
382 'full_name() is correctly implemented' );
384 $person = eval { Person->new( [ qw( Lisa Smith ) ] ) };
385 ok( !$@, 'Person->new() can accept an array reference as an argument' )
387 'You must implement Person->BUILDARGS in order to continue these tests'
390 is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' );
391 is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' );
393 eval { Person->new( sub { 'foo' } ) };
394 like( $@, qr/\QSingle parameters to new() must be a HASH ref/,
395 'Person constructor still rejects bad parameters' );
399 my $employee = Employee->new(
400 first_name => 'Amanda',
401 last_name => 'Palmer',
406 my $orig_super = \&Employee::super;
407 no warnings 'redefine';
408 local *Employee::super = sub { $called++; goto &$orig_super };
410 is( $employee->full_name, 'Amanda Palmer (Singer)',
411 'full_name() is properly overriden in Employee' );
412 ok( $called, 'Employee->full_name calls super()' );
416 my $person = Person->new(
417 first_name => 'Bilbo',
418 last_name => 'Baggins',
422 is( $person->as_string, 'Bilbo Baggins',
423 'as_string() is correctly implemented' );
425 account_tests($person);
429 my $employee = Employee->new(
430 first_name => 'Amanda',
431 last_name => 'Palmer',
436 is( $employee->as_string, 'Amanda Palmer (Singer)',
437 'as_string() uses overridden full_name method in Employee' );
439 account_tests($employee);
443 my $person = Person->new(
444 first_name => 'Bilbo',
445 last_name => 'Baggins',
448 is( $person->full_name, 'Bilbo Baggins',
449 'full_name() is correctly implemented for a Person without a title' );
450 ok( !$person->has_title,
451 'Person has_title predicate is working correctly (returns false)' );
453 $person->title('Ringbearer');
454 ok( $person->has_title, 'Person has_title predicate is working correctly (returns true)' );
457 my $orig_pred = \&Person::has_title;
458 no warnings 'redefine';
459 local *Person::has_title = sub { $called++; goto &$orig_pred };
461 is( $person->full_name, 'Bilbo Baggins (Ringbearer)',
462 'full_name() is correctly implemented for a Person with a title' );
463 ok( $called, 'full_name in person uses the predicate for the title attribute' );
465 $person->clear_title;
466 ok( !$person->has_title, 'Person clear_title method cleared the title' );
468 account_tests( $person, 100 );
472 my $employee = Employee->new(
473 first_name => 'Jimmy',
479 is( $employee->salary, 30000,
480 'salary is calculated from salary_level, and salary passed to constructor is ignored' );
484 my $person = Person->new(
485 first_name => 'Bilbo',
486 last_name => 'Baggins',
489 isa_ok( $person->account, 'BankAccount' );
490 is( $person->account->owner, $person,
491 'owner of bank account is person that created account' );
493 $person->deposit(10);
494 is_deeply( $person->account->history, [ 100 ],
495 'deposit was recorded in account history' );
497 $person->withdraw(15);
498 is_deeply( $person->account->history, [ 100, 110 ],
499 'withdrawal was recorded in account history' );
501 $person->withdraw(45);
502 is_deeply( $person->account->history, [ 100, 110, 95 ],
503 'withdrawal was recorded in account history' );
507 local $Test::Builder::Level = $Test::Builder::Level + 1;
510 my $base_amount = shift || 0;
512 $person->deposit(50);
513 eval { $person->withdraw( 75 + $base_amount ) };
514 like( $@, qr/\QBalance cannot be negative/,
515 'cannot withdraw more than is in our balance' );
517 $person->withdraw( 23 );
519 is( $person->balance, 27 + $base_amount,
520 'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23' );