1 package MooseClass::Tests;
6 use Lingua::EN::Inflect qw( A PL_N );
7 use Scalar::Util qw( blessed );
8 use Test::More 'no_plan';
13 check_isa( 'Person', ['Moose::Object'] );
15 has_rw_attr( 'Person', $_ ) for qw( first_name last_name );
17 has_method( 'Person', 'full_name' );
23 check_isa( 'Employee', [ 'Person', 'Moose::Object' ] );
25 has_rw_attr( 'Employee', $_ ) for qw( title salary );
26 has_ro_attr( 'Employee', 'ssn' );
28 has_overridden_method( 'Employee', 'full_name' );
32 no_droppings('Person');
33 is_immutable('Person');
35 no_droppings('Employee');
36 is_immutable('Employee');
40 has_meta('Printable');
41 requires_method( 'Printable', 'as_string' );
44 does_role( 'Person', 'Printable' );
45 has_method( 'Person', 'as_string' );
47 has_meta('HasAccount');
48 has_method( 'HasAccount', $_ ) for qw( deposit withdraw );
49 has_role_attr( 'HasAccount', 'balance' );
51 does_role( 'Person', 'HasAccount' );
52 has_method( 'Person', $_ ) for qw( deposit withdraw );
53 has_rw_attr( 'Person', 'balance' );
56 does_role( 'Employee', $_ ) for qw( Printable HasAccount );
61 no_droppings($_) for qw( Printable HasAccount );
69 for my $name ( qw( first_name last_name ) ) {
70 has_rw_attr( 'Person', $name );
72 my $attr = Person->meta->get_attribute($name);
73 ok( $attr && $attr->is_required,
74 "$name is required in Person" );
77 has_rw_attr( 'Person', 'title' );
79 my $person_title_attr = Person->meta->get_attribute('title');
80 ok( !$person_title_attr->is_required, 'title is not required in Person' );
82 $person_title_attr->predicate, 'has_title',
83 'Person title attr has a has_title predicate'
86 $person_title_attr->clearer, 'clear_title',
87 'Person title attr has a clear_title clearer'
94 has_rw_attr( 'Employee', 'title', 'overridden' );
96 my $employee_title_attr = Employee->meta->get_attribute('title');
98 $employee_title_attr->default, 'Worker',
99 'title defaults to Worker in Employee'
103 !Employee->meta->has_method('full_name'),
104 'Employee no longer implements a full_name method'
107 has_ro_attr( 'Employee', 'salary' );
109 my $salary_attr = Employee->meta->get_attribute('salary');
110 ok( $salary_attr->is_lazy, 'salary is lazy' );
111 ok( !$salary_attr->init_arg, 'no init_arg for salary attribute' );
112 ok( $salary_attr->has_builder, 'salary attr has a builder' );
114 has_method( 'Employee', '_build_salary' );
116 has_rw_attr( 'Employee', 'salary_level' );
118 my $salary_level_attr = Employee->meta->get_attribute('salary_level');
119 is( $salary_level_attr->default, 1, 'salary_level defaults to 1' );
123 my $balance_attr = Person->meta->get_attribute('balance');
124 is( $balance_attr->default, 100, 'balance defaults to 100' );
130 ok( Person->can('full_name'), 'Person has a full_name() method' )
132 'Person does not have a full_name() method. Cannot continue testing.'
135 my $meth = Person->meta()->get_method('full_name');
137 $meth && $meth->isa('Class::MOP::Method::Wrapped'),
138 'method modifiers have been applied to the Person->full_name method'
142 scalar $meth->before_modifiers,
144 'Person->full_name has a single before modifier'
148 scalar $meth->after_modifiers,
150 'Person->full_name has a single after modifier'
153 my $person = Person->new(
154 first_name => 'Bilbo',
155 last_name => 'Baggins',
161 'Person::CALL global is empty before calling full_name'
164 $person->full_name();
168 [ 'calling full_name', 'called full_name' ],
169 'Person::CALL global contains before and after strings'
173 scalar $meth->around_modifiers,
175 'Person->full_name has a single around modifier'
178 my $larry = Person->new(
179 first_name => 'Larry',
186 'full_name is wrapped by asterisks when last name is Wall'
193 for my $attr_name (qw( first_name last_name title )) {
194 my $attr = Person->meta->get_attribute($attr_name);
197 $attr->has_type_constraint,
198 "Person $attr_name has a type constraint"
201 $attr->type_constraint->name, 'Str',
202 "Person $attr_name type is Str"
206 has_meta('Employee');
209 my $salary_level_attr = Employee->meta->get_attribute('salary_level');
211 $salary_level_attr->has_type_constraint,
212 'Employee salary_level has a type constraint'
215 my $tc = $salary_level_attr->type_constraint;
217 for my $invalid ( 0, 11, -14, 'foo', undef ) {
218 my $str = defined $invalid ? $invalid : 'undef';
220 !$tc->check($invalid),
221 "salary_level type rejects invalid value - $str"
225 for my $valid ( 1 .. 10 ) {
228 "salary_level type accepts valid value - $valid"
234 my $salary_attr = Employee->meta->get_attribute('salary');
237 $salary_attr->has_type_constraint,
238 'Employee salary has a type constraint'
241 my $tc = $salary_attr->type_constraint;
243 for my $invalid ( 0, -14, 'foo', undef ) {
244 my $str = defined $invalid ? $invalid : 'undef';
246 !$tc->check($invalid),
247 "salary type rejects invalid value - $str"
251 for my $valid ( 1, 100_000, 10**10 ) {
254 "salary type accepts valid value - $valid"
260 my $ssn_attr = Employee->meta->get_attribute('ssn');
263 $ssn_attr->has_type_constraint,
264 'Employee ssn has a type constraint'
267 my $tc = $ssn_attr->type_constraint;
269 for my $invalid ( 0, -14, 'foo', undef, '123-ab-1241', '123456789' ) {
270 my $str = defined $invalid ? $invalid : 'undef';
272 !$tc->check($invalid),
273 "ssn type rejects invalid value - $str"
277 for my $valid ( '041-12-1251', '123-45-6789', '926-41-5820' ) {
280 "ssn type accepts valid value - $valid"
285 no_droppings('Employee');
289 has_meta('BankAccount');
291 has_rw_attr( 'BankAccount', $_ ) for qw( balance owner );
293 my $ba_meta = BankAccount->meta;
296 $ba_meta->get_attribute('owner')->is_weak_ref,
297 'owner attribute is a weak ref'
300 has_method( 'BankAccount', $_ ) for qw( deposit withdraw );
302 has_ro_attr( 'BankAccount', 'history' );
304 my $history_attr = $ba_meta->get_attribute('history');
307 $history_attr->default->(),
309 'BankAccount history attribute defaults to []'
313 my $tc = $history_attr->type_constraint;
315 for my $invalid ( 0, 42, undef, {}, [ 'foo', 'bar' ] ) {
316 my $str = defined $invalid ? $invalid : 'undef';
318 !$tc->check($invalid),
319 "salary_level type rejects invalid value - $str"
323 for my $valid ( [], [1], [ 1, 2, 3 ], [ 1, -10, 9999 ] ) {
326 "salary_level type accepts valid value"
332 $history_attr->meta()->can('does_role')
333 && $history_attr->meta()
334 ->does_role('Moose::Meta::Attribute::Native::Trait::Array'),
335 'BankAccount history attribute uses native delegation to an array ref'
339 $ba_meta->get_attribute('balance')->has_trigger,
340 'BankAccount balance attribute has a trigger'
345 my $person_meta = Person->meta;
347 ok( !$person_meta->does_role('HasAccount'),
348 'Person class does not do the HasAccount role' );
351 !$person_meta->has_attribute('balance'),
352 'Person class does not have a balance attribute'
355 my $deposit_meth = $person_meta->get_method('deposit');
357 $deposit_meth, 'Moose::Meta::Method::Delegation',
358 'The Person->deposit method exists and is a delegation method'
361 my $withdraw_meth = $person_meta->get_method('withdraw');
363 $withdraw_meth, 'Moose::Meta::Method::Delegation',
364 'The Person->withdraw method exists and is a delegation method'
369 has_meta('Employee');
371 no_droppings('BankAccount');
377 local $Test::Builder::Level = $Test::Builder::Level + 1;
381 local $SIG{__WARN__} = sub { push @warn, @_ };
384 or BAIL_OUT("$package cannot be loaded");
386 BAIL_OUT("Warning when loading $package: @warn")
390 ok( $package->can('meta'), "$package has a meta() method" )
392 "$package does not have a meta() method (did you forget to 'use Moose'?)"
400 local $Test::Builder::Level = $Test::Builder::Level + 1;
402 my @isa = $class->meta->linearized_isa;
403 shift @isa; # returns $class as the first entry
405 my $count = scalar @{$parents};
406 my $noun = PL_N( 'parent', $count );
408 is( scalar @isa, $count, "$class has $count $noun" );
410 for ( my $i = 0; $i < @{$parents}; $i++ ) {
411 is( $isa[$i], $parents->[$i], "parent[$i] is $parents->[$i]" );
418 my $overridden = shift;
420 local $Test::Builder::Level = $Test::Builder::Level + 1;
422 my $articled = $overridden ? "an overridden $name" : A($name);
424 $class->meta->has_attribute($name),
425 "$class has $articled attribute"
428 my $attr = $class->meta->get_attribute($name);
431 $attr->get_read_method, $name,
432 "$name attribute has a reader accessor - $name()"
435 $attr->get_write_method, $name,
436 "$name attribute has a writer accessor - $name()"
444 local $Test::Builder::Level = $Test::Builder::Level + 1;
446 my $articled = A($name);
448 $class->meta->has_attribute($name),
449 "$class has $articled attribute"
452 my $attr = $class->meta->get_attribute($name);
455 $attr->get_read_method, $name,
456 "$name attribute has a reader accessor - $name()"
459 $attr->get_write_method, undef,
460 "$name attribute does not have a writer"
468 local $Test::Builder::Level = $Test::Builder::Level + 1;
470 my $articled = A($name);
472 $role->meta->get_attribute($name),
473 "$role has $articled attribute"
481 local $Test::Builder::Level = $Test::Builder::Level + 1;
483 my $articled = A($name);
484 ok( $package->meta->has_method($name), "$package has $articled method" );
487 sub has_overridden_method {
491 local $Test::Builder::Level = $Test::Builder::Level + 1;
493 my $articled = A($name);
494 ok( $package->meta->has_method($name), "$package has $articled method" );
496 my $meth = $package->meta->get_method($name);
498 $meth, 'Moose::Meta::Method::Overridden',
499 "The $name method is an overridden method"
503 sub requires_method {
507 local $Test::Builder::Level = $Test::Builder::Level + 1;
510 $package->meta->requires_method($method),
511 "$package requires the method $method"
518 local $Test::Builder::Level = $Test::Builder::Level + 1;
520 ok( !$package->can('has'), "no Moose droppings in $package" );
521 ok( !$package->can('subtype'),
522 "no Moose::Util::TypeConstraints droppings in $package" );
528 local $Test::Builder::Level = $Test::Builder::Level + 1;
530 ok( $class->meta->is_immutable, "$class has been made immutable" );
537 local $Test::Builder::Level = $Test::Builder::Level + 1;
539 ok( $package->meta->does_role($role), "$package does the $role role" );
543 my $person = Person->new(
544 first_name => 'Bilbo',
545 last_name => 'Baggins',
549 $person->full_name, 'Bilbo Baggins',
550 'full_name() is correctly implemented'
553 $person = eval { Person->new( [ qw( Lisa Smith ) ] ) };
557 "Calling Person->new() with an array reference threw an error:\n$e"
560 'You must implement Person->BUILDARGS correctly in order to continue these tests'
564 ok( 1, 'Person->new() can accept an array reference as an argument' );
567 is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' );
568 is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' );
571 Person->new( sub {'foo'} );
574 $@, qr/\QSingle parameters to new() must be a HASH ref/,
575 'Person constructor still rejects bad parameters'
580 my $employee = Employee->new(
581 first_name => 'Amanda',
582 last_name => 'Palmer',
587 my $orig_super = \&Employee::super;
588 no warnings 'redefine';
589 local *Employee::super = sub { $called++; goto &$orig_super };
592 $employee->full_name, 'Amanda Palmer (Singer)',
593 'full_name() is properly overriden in Employee'
595 ok( $called, 'Employee->full_name calls super()' );
599 my $person = Person->new(
600 first_name => 'Bilbo',
601 last_name => 'Baggins',
606 $person->as_string, 'Bilbo Baggins',
607 'as_string() is correctly implemented'
610 account_tests($person);
614 my $employee = Employee->new(
615 first_name => 'Amanda',
616 last_name => 'Palmer',
622 $employee->as_string, 'Amanda Palmer (Singer)',
623 'as_string() uses overridden full_name method in Employee'
626 account_tests($employee);
630 my $person = Person->new(
631 first_name => 'Bilbo',
632 last_name => 'Baggins',
636 $person->full_name, 'Bilbo Baggins',
637 'full_name() is correctly implemented for a Person without a title'
641 'Person has_title predicate is working correctly (returns false)'
644 $person->title('Ringbearer');
645 ok( $person->has_title,
646 'Person has_title predicate is working correctly (returns true)' );
649 my $orig_pred = \&Person::has_title;
650 no warnings 'redefine';
651 local *Person::has_title = sub { $called++; goto &$orig_pred };
654 $person->full_name, 'Bilbo Baggins (Ringbearer)',
655 'full_name() is correctly implemented for a Person with a title'
658 'full_name in person uses the predicate for the title attribute' );
660 $person->clear_title;
661 ok( !$person->has_title, 'Person clear_title method cleared the title' );
663 account_tests( $person, 100 );
667 my $employee = Employee->new(
668 first_name => 'Jimmy',
675 $employee->salary, 30000,
676 'salary is calculated from salary_level, and salary passed to constructor is ignored'
681 my $account = BankAccount->new();
683 my $person = Person->new(
684 first_name => 'Bilbo',
685 last_name => 'Baggins',
690 $person->account, $account,
691 'account object passed to Person->new is still in object'
695 $person->account, 'BankAccount',
696 'The value of $person->account() isa BankAccount object'
700 $person->account->owner, $person,
701 'owner of bank account is person that created account'
704 $person->deposit(10);
706 $person->account->history, [100],
707 'deposit was recorded in account history'
710 $person->withdraw(15);
712 $person->account->history, [ 100, 110 ],
713 'withdrawal was recorded in account history'
716 $person->withdraw(45);
718 $person->account->history, [ 100, 110, 95 ],
719 'withdrawal was recorded in account history'
724 local $Test::Builder::Level = $Test::Builder::Level + 1;
727 my $base_amount = shift || 0;
729 $person->deposit(50);
732 $person->balance, 50 + $base_amount,
733 "balance is 50 + $base_amount",
736 eval { $person->withdraw( 75 + $base_amount ) };
738 $@, qr/\QBalance cannot be negative/,
739 'cannot withdraw more than is in our balance'
742 $person->withdraw(23);
745 $person->balance, 27 + $base_amount,
746 'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23'
755 local $Test::Builder::Level = $Test::Builder::Level + 1;
758 $thing && ( blessed $thing || !ref $thing ) && $thing->isa($class),