1 package MooseClass::Tests;
6 use Lingua::EN::Inflect qw( A PL_N );
7 use Test::More 'no_plan';
12 check_isa( 'Person', ['Moose::Object'] );
14 has_rw_attr( 'Person', $_ ) for qw( first_name last_name );
16 has_method( 'Person', 'full_name' );
22 check_isa( 'Employee', [ 'Person', 'Moose::Object' ] );
24 has_rw_attr( 'Employee', $_ ) for qw( title salary );
25 has_ro_attr( 'Employee', 'ssn' );
27 has_overridden_method( 'Employee', 'full_name' );
31 no_droppings('Person');
32 is_immutable('Person');
34 no_droppings('Employee');
35 is_immutable('Employee');
39 has_meta('Printable');
40 requires_method( 'Printable', 'as_string' );
43 does_role( 'Person', 'Printable' );
44 has_method( 'Person', 'as_string' );
46 has_meta('HasAccount');
47 has_method( 'HasAccount', $_ ) for qw( deposit withdraw );
48 has_role_attr( 'HasAccount', 'balance' );
50 does_role( 'Person', 'HasAccount' );
51 has_method( 'Person', $_ ) for qw( deposit withdraw );
52 has_rw_attr( 'Person', 'balance' );
55 does_role( 'Employee', $_ ) for qw( Printable HasAccount );
60 no_droppings($_) for qw( Printable HasAccount );
68 for my $name ( qw( first_name last_name ) ) {
69 has_rw_attr( 'Person', $name );
71 my $attr = Person->meta->get_attribute($name);
72 ok( $attr && $attr->is_required,
73 "$name is required in Person" );
76 has_rw_attr( 'Person', 'title' );
78 my $person_title_attr = Person->meta->get_attribute('title');
79 ok( !$person_title_attr->is_required, 'title is not required in Person' );
81 $person_title_attr->predicate, 'has_title',
82 'Person title attr has a has_title predicate'
85 $person_title_attr->clearer, 'clear_title',
86 'Person title attr has a clear_title clearer'
93 has_rw_attr( 'Employee', 'title', 'overridden' );
95 my $employee_title_attr = Employee->meta->get_attribute('title');
97 $employee_title_attr->default, 'Worker',
98 'title defaults to Worker in Employee'
102 !Employee->meta->has_method('full_name'),
103 'Employee no longer implements a full_name method'
106 has_ro_attr( 'Employee', 'salary' );
108 my $salary_attr = Employee->meta->get_attribute('salary');
109 ok( $salary_attr->is_lazy, 'salary is lazy' );
110 ok( !$salary_attr->init_arg, 'no init_arg for salary attribute' );
111 ok( $salary_attr->has_builder, 'salary attr has a builder' );
113 has_method( 'Employee', '_build_salary' );
115 has_rw_attr( 'Employee', 'salary_level' );
117 my $salary_level_attr = Employee->meta->get_attribute('salary_level');
118 is( $salary_level_attr->default, 1, 'salary_level defaults to 1' );
122 my $balance_attr = Person->meta->get_attribute('balance');
123 is( $balance_attr->default, 100, 'balance defaults to 100' );
129 ok( Person->can('full_name'), 'Person has a full_name() method' )
131 'Person does not have a full_name() method. Cannot continue testing.'
134 my $meth = Person->meta()->get_method('full_name');
136 $meth && $meth->isa('Class::MOP::Method::Wrapped'),
137 'method modifiers have been applied to the Person->full_name method'
141 scalar $meth->before_modifiers,
143 'Person->full_name has a single before modifier'
147 scalar $meth->after_modifiers,
149 'Person->full_name has a single after modifier'
152 my $person = Person->new(
153 first_name => 'Bilbo',
154 last_name => 'Baggins',
160 'Person::CALL global is empty before calling full_name'
163 $person->full_name();
167 [ 'calling full_name', 'called full_name' ],
168 'Person::CALL global contains before and after strings'
172 scalar $meth->around_modifiers,
174 'Person->full_name has a single around modifier'
177 my $larry = Person->new(
178 first_name => 'Larry',
185 'full_name is wrapped by asterisks when last name is Wall'
192 for my $attr_name (qw( first_name last_name title )) {
193 my $attr = Person->meta->get_attribute($attr_name);
196 $attr->has_type_constraint,
197 "Person $attr_name has a type constraint"
200 $attr->type_constraint->name, 'Str',
201 "Person $attr_name type is Str"
205 has_meta('Employee');
208 my $salary_level_attr = Employee->meta->get_attribute('salary_level');
210 $salary_level_attr->has_type_constraint,
211 'Employee salary_level has a type constraint'
214 my $tc = $salary_level_attr->type_constraint;
216 for my $invalid ( 0, 11, -14, 'foo', undef ) {
217 my $str = defined $invalid ? $invalid : 'undef';
219 !$tc->check($invalid),
220 "salary_level type rejects invalid value - $str"
224 for my $valid ( 1 .. 10 ) {
227 "salary_level type accepts valid value - $valid"
233 my $salary_attr = Employee->meta->get_attribute('salary');
236 $salary_attr->has_type_constraint,
237 'Employee salary has a type constraint'
240 my $tc = $salary_attr->type_constraint;
242 for my $invalid ( 0, -14, 'foo', undef ) {
243 my $str = defined $invalid ? $invalid : 'undef';
245 !$tc->check($invalid),
246 "salary type rejects invalid value - $str"
250 for my $valid ( 1, 100_000, 10**10 ) {
253 "salary type accepts valid value - $valid"
259 my $ssn_attr = Employee->meta->get_attribute('ssn');
262 $ssn_attr->has_type_constraint,
263 'Employee ssn has a type constraint'
266 my $tc = $ssn_attr->type_constraint;
268 for my $invalid ( 0, -14, 'foo', undef, '123-ab-1241', '123456789' ) {
269 my $str = defined $invalid ? $invalid : 'undef';
271 !$tc->check($invalid),
272 "ssn type rejects invalid value - $str"
276 for my $valid ( '041-12-1251', '123-45-6789', '926-41-5820' ) {
279 "ssn type accepts valid value - $valid"
284 no_droppings('Employee');
288 has_meta('BankAccount');
290 has_rw_attr( 'BankAccount', $_ ) for qw( balance owner );
292 my $ba_meta = BankAccount->meta;
295 $ba_meta->get_attribute('owner')->is_weak_ref,
296 'owner attribute is a weak ref'
299 has_method( 'BankAccount', $_ ) for qw( deposit withdraw );
301 has_ro_attr( 'BankAccount', 'history' );
303 my $history_attr = $ba_meta->get_attribute('history');
306 $history_attr->default->(),
308 'BankAccount history attribute defaults to []'
312 my $tc = $history_attr->type_constraint;
314 for my $invalid ( 0, 42, undef, {}, [ 'foo', 'bar' ] ) {
315 my $str = defined $invalid ? $invalid : 'undef';
317 !$tc->check($invalid),
318 "salary_level type rejects invalid value - $str"
322 for my $valid ( [], [1], [ 1, 2, 3 ], [ 1, -10, 9999 ] ) {
325 "salary_level type accepts valid value"
331 $history_attr->meta()->can('does_role')
332 && $history_attr->meta()
333 ->does_role('Moose::Meta::Attribute::Native::Trait::Array'),
334 'BankAccount history attribute uses native delegation to an array ref'
338 $ba_meta->get_attribute('balance')->has_trigger,
339 'BankAccount balance attribute has a trigger'
344 my $person_meta = Person->meta;
346 ok( !$person_meta->does_role('HasAccount'),
347 'Person class does not do the HasAccount role' );
350 !$person_meta->has_attribute('balance'),
351 'Person class does not have a balance attribute'
354 my $deposit_meth = $person_meta->get_method('deposit');
355 isa_ok( $deposit_meth, 'Moose::Meta::Method::Delegation' );
357 my $withdraw_meth = $person_meta->get_method('withdraw');
358 isa_ok( $withdraw_meth, 'Moose::Meta::Method::Delegation' );
362 has_meta('Employee');
364 no_droppings('BankAccount');
370 local $Test::Builder::Level = $Test::Builder::Level + 1;
374 local $SIG{__WARN__} = sub { push @warn, @_ };
377 or BAIL_OUT("$package cannot be loaded");
379 BAIL_OUT("Warning when loading $package: @warn")
383 ok( $package->can('meta'), "$package has a meta() method" )
385 "$package does not have a meta() method (did you forget to 'use Moose'?)"
393 local $Test::Builder::Level = $Test::Builder::Level + 1;
395 my @isa = $class->meta->linearized_isa;
396 shift @isa; # returns $class as the first entry
398 my $count = scalar @{$parents};
399 my $noun = PL_N( 'parent', $count );
401 is( scalar @isa, $count, "$class has $count $noun" );
403 for ( my $i = 0; $i < @{$parents}; $i++ ) {
404 is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" );
411 my $overridden = shift;
413 local $Test::Builder::Level = $Test::Builder::Level + 1;
415 my $articled = $overridden ? "an overridden $name" : A($name);
417 $class->meta->has_attribute($name),
418 "$class has $articled attribute"
421 my $attr = $class->meta->get_attribute($name);
424 $attr->get_read_method, $name,
425 "$name attribute has a reader accessor - $name()"
428 $attr->get_write_method, $name,
429 "$name attribute has a writer accessor - $name()"
437 local $Test::Builder::Level = $Test::Builder::Level + 1;
439 my $articled = A($name);
441 $class->meta->has_attribute($name),
442 "$class has $articled attribute"
445 my $attr = $class->meta->get_attribute($name);
448 $attr->get_read_method, $name,
449 "$name attribute has a reader accessor - $name()"
452 $attr->get_write_method, undef,
453 "$name attribute does not have a writer"
461 local $Test::Builder::Level = $Test::Builder::Level + 1;
463 my $articled = A($name);
465 $role->meta->get_attribute($name),
466 "$role has $articled attribute"
474 local $Test::Builder::Level = $Test::Builder::Level + 1;
476 my $articled = A($name);
477 ok( $package->meta->has_method($name), "$package has $articled method" );
480 sub has_overridden_method {
484 local $Test::Builder::Level = $Test::Builder::Level + 1;
486 my $articled = A($name);
487 ok( $package->meta->has_method($name), "$package has $articled method" );
489 my $meth = $package->meta->get_method($name);
490 isa_ok( $meth, 'Moose::Meta::Method::Overridden' );
493 sub has_augmented_method {
497 local $Test::Builder::Level = $Test::Builder::Level + 1;
499 my $articled = A($name);
500 ok( $class->meta->has_method($name), "$class has $articled method" );
502 my $meth = $class->meta->get_method($name);
503 isa_ok( $meth, 'Moose::Meta::Method::Augmented' );
506 sub requires_method {
510 local $Test::Builder::Level = $Test::Builder::Level + 1;
513 $package->meta->requires_method($method),
514 "$package requires the method $method"
521 local $Test::Builder::Level = $Test::Builder::Level + 1;
523 ok( !$package->can('has'), "no Moose droppings in $package" );
524 ok( !$package->can('subtype'),
525 "no Moose::Util::TypeConstraints droppings in $package" );
531 local $Test::Builder::Level = $Test::Builder::Level + 1;
533 ok( $class->meta->is_immutable, "$class has been made immutable" );
540 local $Test::Builder::Level = $Test::Builder::Level + 1;
542 ok( $package->meta->does_role($role), "$package does the $role role" );
546 my $person = Person->new(
547 first_name => 'Bilbo',
548 last_name => 'Baggins',
552 $person->full_name, 'Bilbo Baggins',
553 'full_name() is correctly implemented'
556 $person = eval { Person->new( [ qw( Lisa Smith ) ] ) };
560 "Calling Person->new() with an array reference threw an error:\n$e"
563 'You must implement Person->BUILDARGS correctly in order to continue these tests'
567 ok( 1, 'Person->new() can accept an array reference as an argument' );
570 is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' );
571 is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' );
574 Person->new( sub {'foo'} );
577 $@, qr/\QSingle parameters to new() must be a HASH ref/,
578 'Person constructor still rejects bad parameters'
583 my $employee = Employee->new(
584 first_name => 'Amanda',
585 last_name => 'Palmer',
590 my $orig_super = \&Employee::super;
591 no warnings 'redefine';
592 local *Employee::super = sub { $called++; goto &$orig_super };
595 $employee->full_name, 'Amanda Palmer (Singer)',
596 'full_name() is properly overriden in Employee'
598 ok( $called, 'Employee->full_name calls super()' );
602 my $person = Person->new(
603 first_name => 'Bilbo',
604 last_name => 'Baggins',
609 $person->as_string, 'Bilbo Baggins',
610 'as_string() is correctly implemented'
613 account_tests($person);
617 my $employee = Employee->new(
618 first_name => 'Amanda',
619 last_name => 'Palmer',
625 $employee->as_string, 'Amanda Palmer (Singer)',
626 'as_string() uses overridden full_name method in Employee'
629 account_tests($employee);
633 my $person = Person->new(
634 first_name => 'Bilbo',
635 last_name => 'Baggins',
639 $person->full_name, 'Bilbo Baggins',
640 'full_name() is correctly implemented for a Person without a title'
644 'Person has_title predicate is working correctly (returns false)'
647 $person->title('Ringbearer');
648 ok( $person->has_title,
649 'Person has_title predicate is working correctly (returns true)' );
652 my $orig_pred = \&Person::has_title;
653 no warnings 'redefine';
654 local *Person::has_title = sub { $called++; goto &$orig_pred };
657 $person->full_name, 'Bilbo Baggins (Ringbearer)',
658 'full_name() is correctly implemented for a Person with a title'
661 'full_name in person uses the predicate for the title attribute' );
663 $person->clear_title;
664 ok( !$person->has_title, 'Person clear_title method cleared the title' );
666 account_tests( $person, 100 );
670 my $employee = Employee->new(
671 first_name => 'Jimmy',
678 $employee->salary, 30000,
679 'salary is calculated from salary_level, and salary passed to constructor is ignored'
684 my $account = BankAccount->new();
686 my $person = Person->new(
687 first_name => 'Bilbo',
688 last_name => 'Baggins',
693 $person->account, $account,
694 'account object passed to Person->new is still in object'
697 isa_ok( $person->account, 'BankAccount' );
699 $person->account->owner, $person,
700 'owner of bank account is person that created account'
703 $person->deposit(10);
705 $person->account->history, [100],
706 'deposit was recorded in account history'
709 $person->withdraw(15);
711 $person->account->history, [ 100, 110 ],
712 'withdrawal was recorded in account history'
715 $person->withdraw(45);
717 $person->account->history, [ 100, 110, 95 ],
718 'withdrawal was recorded in account history'
723 local $Test::Builder::Level = $Test::Builder::Level + 1;
726 my $base_amount = shift || 0;
728 $person->deposit(50);
731 $person->balance, 50 + $base_amount,
732 "balance is 50 + $base_amount",
735 eval { $person->withdraw( 75 + $base_amount ) };
737 $@, qr/\QBalance cannot be negative/,
738 'cannot withdraw more than is in our balance'
741 $person->withdraw(23);
744 $person->balance, 27 + $base_amount,
745 'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23'