use Test::More 'no_plan';
sub tests01 {
- my %p = (
- person_attr_count => 2,
- employee_attr_count => 3,
- @_,
- );
-
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
has_meta('Person');
check_isa( 'Person', ['Moose::Object'] );
- count_attrs( 'Person', $p{person_attr_count} );
-
has_rw_attr( 'Person', $_ ) for qw( first_name last_name );
has_method( 'Person', 'full_name' );
- no_droppings('Person');
- is_immutable('Person');
-
person01();
has_meta('Employee');
check_isa( 'Employee', [ 'Person', 'Moose::Object' ] );
- count_attrs( 'Employee', $p{employee_attr_count} );
-
has_rw_attr( 'Employee', $_ ) for qw( title salary );
has_ro_attr( 'Employee', 'ssn' );
has_overridden_method( 'Employee', 'full_name' );
employee01();
+
+ no_droppings('Person');
+ is_immutable('Person');
}
sub tests02 {
- tests01( person_attr_count => 3, @_ );
+ has_meta('Printable');
+ requires_method( 'Printable', 'as_string' );
- local $Test::Builder::Level = $Test::Builder::Level + 1;
+ has_meta('Person');
+ does_role( 'Person', 'Printable' );
+ has_method( 'Person', 'as_string' );
- no_droppings($_) for qw( Printable HasAccount );
+ has_meta('HasAccount');
+ has_method( 'HasAccount', $_ ) for qw( deposit withdraw );
+ has_role_attr( 'HasAccount', 'balance' );
- does_role( 'Person', $_ ) for qw( Printable HasAccount );
- has_method( 'Person', $_ ) for qw( as_string deposit withdraw );
+ does_role( 'Person', 'HasAccount' );
+ has_method( 'Person', $_ ) for qw( deposit withdraw );
has_rw_attr( 'Person', 'balance' );
+ has_meta('Employee');
does_role( 'Employee', $_ ) for qw( Printable HasAccount );
person02();
employee02();
-}
-sub tests03 {
- {
- local $Test::Builder::Level = $Test::Builder::Level + 1;
+ no_droppings($_) for qw( Printable HasAccount );
- has_meta('Person');
- has_meta('Employee');
+ tests01();
+}
- has_rw_attr( 'Person', 'title' );
+sub tests03 {
+ has_meta('Person');
- has_rw_attr( 'Employee', 'title' );
- has_rw_attr( 'Employee', 'salary_level' );
- has_ro_attr( 'Employee', 'salary' );
+ for my $name ( qw( first_name last_name ) ) {
+ has_rw_attr( 'Person', $name );
- has_method( 'Employee', '_build_salary' );
+ my $attr = Person->meta->get_attribute($name);
+ ok( $attr && $attr->is_required,
+ "$name is required in Person" );
}
- ok( ! Employee->meta->has_method('full_name'),
- 'Employee no longer implements a full_name method' );
+ has_rw_attr( 'Person', 'title' );
my $person_title_attr = Person->meta->get_attribute('title');
ok( !$person_title_attr->is_required, 'title is not required in Person' );
- is( $person_title_attr->predicate, 'has_title',
- 'Person title attr has a has_title predicate' );
- is( $person_title_attr->clearer, 'clear_title',
- 'Person title attr has a clear_title clearer' );
+ is(
+ $person_title_attr->predicate, 'has_title',
+ 'Person title attr has a has_title predicate'
+ );
+ is(
+ $person_title_attr->clearer, 'clear_title',
+ 'Person title attr has a clear_title clearer'
+ );
- my $balance_attr = Person->meta->get_attribute('balance');
- is( $balance_attr->default, 100, 'balance defaults to 100' );
+ person03();
+
+ has_meta('Employee');
+
+ has_rw_attr( 'Employee', 'title', 'overridden' );
my $employee_title_attr = Employee->meta->get_attribute('title');
- is( $employee_title_attr->default, 'Worker',
- 'title defaults to Worker in Employee' );
+ is(
+ $employee_title_attr->default, 'Worker',
+ 'title defaults to Worker in Employee'
+ );
- my $salary_level_attr = Employee->meta->get_attribute('salary_level');
- is( $salary_level_attr->default, 1, 'salary_level defaults to 1' );
+ ok(
+ !Employee->meta->has_method('full_name'),
+ 'Employee no longer implements a full_name method'
+ );
+
+ has_ro_attr( 'Employee', 'salary' );
my $salary_attr = Employee->meta->get_attribute('salary');
+ ok( $salary_attr->is_lazy, 'salary is lazy' );
ok( !$salary_attr->init_arg, 'no init_arg for salary attribute' );
ok( $salary_attr->has_builder, 'salary attr has a builder' );
- person03();
+ has_method( 'Employee', '_build_salary' );
+
+ has_rw_attr( 'Employee', 'salary_level' );
+
+ my $salary_level_attr = Employee->meta->get_attribute('salary_level');
+ is( $salary_level_attr->default, 1, 'salary_level defaults to 1' );
+
employee03();
+
+ my $balance_attr = Person->meta->get_attribute('balance');
+ is( $balance_attr->default, 100, 'balance defaults to 100' );
}
sub tests04 {
- {
- local $Test::Builder::Level = $Test::Builder::Level + 1;
+ has_meta('Person');
- no_droppings('OutputsXML');
+ ok( Person->can('full_name'), 'Person has a full_name() method' )
+ or BAIL_OUT(
+ 'Person does not have a full_name() method. Cannot continue testing.'
+ );
+
+ my $meth = Person->meta()->get_method('full_name');
+ ok(
+ $meth && $meth->isa('Class::MOP::Method::Wrapped'),
+ 'method modifiers have been applied to the Person->full_name method'
+ );
+
+ is(
+ scalar $meth->before_modifiers,
+ 1,
+ 'Person->full_name has a single before modifier'
+ );
+
+ is(
+ scalar $meth->after_modifiers,
+ 1,
+ 'Person->full_name has a single after modifier'
+ );
- does_role( 'Person', 'OutputsXML' );
+ my $person = Person->new(
+ first_name => 'Bilbo',
+ last_name => 'Baggins',
+ );
+
+ is_deeply(
+ \@Person::CALL,
+ [],
+ 'Person::CALL global is empty before calling full_name'
+ );
+
+ $person->full_name();
+
+ is_deeply(
+ \@Person::CALL,
+ [ 'calling full_name', 'called full_name' ],
+ 'Person::CALL global contains before and after strings'
+ );
+
+ is(
+ scalar $meth->around_modifiers,
+ 1,
+ 'Person->full_name has a single around modifier'
+ );
+
+ my $larry = Person->new(
+ first_name => 'Larry',
+ last_name => 'Wall',
+ );
+
+ is(
+ $larry->full_name,
+ '*Larry Wall*',
+ 'full_name is wrapped by asterisks when last name is Wall'
+ );
+}
+
+sub tests05 {
+ has_meta('Person');
+
+ for my $attr_name (qw( first_name last_name title )) {
+ my $attr = Person->meta->get_attribute($attr_name);
+
+ ok(
+ $attr->has_type_constraint,
+ "Person $attr_name has a type constraint"
+ );
+ is(
+ $attr->type_constraint->name, 'Str',
+ "Person $attr_name type is Str"
+ );
}
- ok( scalar OutputsXML->meta->get_around_method_modifiers('as_xml'),
- 'OutputsXML has an around modifier for as_xml' );
+ has_meta('Employee');
+
+ {
+ my $salary_level_attr = Employee->meta->get_attribute('salary_level');
+ ok(
+ $salary_level_attr->has_type_constraint,
+ 'Employee salary_level has a type constraint'
+ );
+
+ my $tc = $salary_level_attr->type_constraint;
+
+ for my $invalid ( 0, 11, -14, 'foo', undef ) {
+ my $str = defined $invalid ? $invalid : 'undef';
+ ok(
+ !$tc->check($invalid),
+ "salary_level type rejects invalid value - $str"
+ );
+ }
+
+ for my $valid ( 1 .. 10 ) {
+ ok(
+ $tc->check($valid),
+ "salary_level type accepts valid value - $valid"
+ );
+ }
+ }
+
+ {
+ my $salary_attr = Employee->meta->get_attribute('salary');
+
+ ok(
+ $salary_attr->has_type_constraint,
+ 'Employee salary has a type constraint'
+ );
+
+ my $tc = $salary_attr->type_constraint;
+
+ for my $invalid ( 0, -14, 'foo', undef ) {
+ my $str = defined $invalid ? $invalid : 'undef';
+ ok(
+ !$tc->check($invalid),
+ "salary type rejects invalid value - $str"
+ );
+ }
+
+ for my $valid ( 1, 100_000, 10**10 ) {
+ ok(
+ $tc->check($valid),
+ "salary type accepts valid value - $valid"
+ );
+ }
+ }
- isa_ok( Employee->meta->get_method('as_xml'),
- 'Moose::Meta::Method::Augmented', 'as_xml is augmented in Employee' );
+ {
+ my $ssn_attr = Employee->meta->get_attribute('ssn');
+
+ ok(
+ $ssn_attr->has_type_constraint,
+ 'Employee ssn has a type constraint'
+ );
+
+ my $tc = $ssn_attr->type_constraint;
+
+ for my $invalid ( 0, -14, 'foo', undef, '123-ab-1241', '123456789' ) {
+ my $str = defined $invalid ? $invalid : 'undef';
+ ok(
+ !$tc->check($invalid),
+ "ssn type rejects invalid value - $str"
+ );
+ }
+
+ for my $valid ( '041-12-1251', '123-45-6789', '926-41-5820' ) {
+ ok(
+ $tc->check($valid),
+ "ssn type accepts valid value - $valid"
+ );
+ }
+ }
- person04();
- employee04();
+ no_droppings('Employee');
}
sub tests06 {
- {
- local $Test::Builder::Level = $Test::Builder::Level + 1;
+ has_meta('BankAccount');
+
+ has_rw_attr( 'BankAccount', $_ ) for qw( balance owner );
- has_meta('BankAccount');
- no_droppings('BankAccount');
+ my $ba_meta = BankAccount->meta;
+
+ ok(
+ $ba_meta->get_attribute('owner')->is_weak_ref,
+ 'owner attribute is a weak ref'
+ );
- has_rw_attr( 'BankAccount', 'balance' );
- has_rw_attr( 'BankAccount', 'owner' );
- has_ro_attr( 'BankAccount', 'history' );
+ has_method( 'BankAccount', $_ ) for qw( deposit withdraw );
+
+ has_ro_attr( 'BankAccount', 'history' );
+
+ my $history_attr = $ba_meta->get_attribute('history');
+
+ is_deeply(
+ $history_attr->default->(),
+ [],
+ 'BankAccount history attribute defaults to []'
+ );
+
+ {
+ my $tc = $history_attr->type_constraint;
+
+ for my $invalid ( 0, 42, undef, {}, [ 'foo', 'bar' ] ) {
+ my $str = defined $invalid ? $invalid : 'undef';
+ ok(
+ !$tc->check($invalid),
+ "salary_level type rejects invalid value - $str"
+ );
+ }
+
+ for my $valid ( [], [1], [ 1, 2, 3 ], [ 1, -10, 9999 ] ) {
+ ok(
+ $tc->check($valid),
+ "salary_level type accepts valid value"
+ );
+ }
}
+ ok(
+ $history_attr->meta()
+ ->does_role('Moose::Meta::Attribute::Native::Trait::Array'),
+ 'BankAccount history attribute uses native delegation to an array ref'
+ );
+
+ ok(
+ $ba_meta->get_attribute('balance')->has_trigger,
+ 'BankAccount balance attribute has a trigger'
+ );
+
+ has_meta('Person');
+
my $person_meta = Person->meta;
- ok( ! $person_meta->has_attribute('balance'),
- 'Person class does not have a balance attribute' );
+
+ ok( !$person_meta->does_role('HasAccount'),
+ 'Person class does not do the HasAccount role' );
+
+ ok(
+ !$person_meta->has_attribute('balance'),
+ 'Person class does not have a balance attribute'
+ );
my $deposit_meth = $person_meta->get_method('deposit');
isa_ok( $deposit_meth, 'Moose::Meta::Method::Delegation' );
my $withdraw_meth = $person_meta->get_method('withdraw');
isa_ok( $withdraw_meth, 'Moose::Meta::Method::Delegation' );
- my $ba_meta = BankAccount->meta;
- ok( $ba_meta->get_attribute('owner')->is_weak_ref,
- 'owner attribute is a weak ref' );
-
person06();
-}
+ has_meta('Employee');
+
+ no_droppings('BankAccount');
+}
sub has_meta {
- my $class = shift;
+ my $package = shift;
- ok( $class->can('meta'), "$class has a meta() method" )
- or BAIL_OUT("Cannot run tests against a class without a meta!");
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ use_ok($package)
+ or BAIL_OUT("$package cannot be loaded");
+
+ ok( $package->can('meta'), "$package has a meta() method" )
+ or BAIL_OUT(
+ "$package does not have a meta() method (did you forget to 'use Moose'?)"
+ );
}
sub check_isa {
my $class = shift;
my $parents = shift;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
my @isa = $class->meta->linearized_isa;
shift @isa; # returns $class as the first entry
}
}
-sub count_attrs {
- my $class = shift;
- my $count = shift;
-
- my $noun = PL_N( 'attribute', $count );
- is( scalar $class->meta->get_attribute_list, $count,
- "$class defines $count $noun" );
-}
-
sub has_rw_attr {
- my $class = shift;
- my $name = shift;
+ my $class = shift;
+ my $name = shift;
+ my $overridden = shift;
- my $articled = A($name);
- ok( $class->meta->has_attribute($name),
- "$class has $articled attribute" );
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my $articled = $overridden ? "an overridden $name" : A($name);
+ ok(
+ $class->meta->has_attribute($name),
+ "$class has $articled attribute"
+ );
my $attr = $class->meta->get_attribute($name);
- is( $attr->get_read_method, $name,
- "$name attribute has a reader accessor - $name()" );
- is( $attr->get_write_method, $name,
- "$name attribute has a writer accessor - $name()" );
+ is(
+ $attr->get_read_method, $name,
+ "$name attribute has a reader accessor - $name()"
+ );
+ is(
+ $attr->get_write_method, $name,
+ "$name attribute has a writer accessor - $name()"
+ );
}
sub has_ro_attr {
my $class = shift;
my $name = shift;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
my $articled = A($name);
- ok( $class->meta->has_attribute($name),
- "$class has $articled attribute" );
+ ok(
+ $class->meta->has_attribute($name),
+ "$class has $articled attribute"
+ );
my $attr = $class->meta->get_attribute($name);
- is( $attr->get_read_method, $name,
- "$name attribute has a reader accessor - $name()" );
- is( $attr->get_write_method, undef,
- "$name attribute does not have a writer" );
+ is(
+ $attr->get_read_method, $name,
+ "$name attribute has a reader accessor - $name()"
+ );
+ is(
+ $attr->get_write_method, undef,
+ "$name attribute does not have a writer"
+ );
+}
+
+sub has_role_attr {
+ my $role = shift;
+ my $name = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my $articled = A($name);
+ ok(
+ $role->meta->get_attribute($name),
+ "$role has $articled attribute"
+ );
}
sub has_method {
- my $class = shift;
- my $name = shift;
+ my $package = shift;
+ my $name = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
my $articled = A($name);
- ok( $class->meta->has_method($name), "$class has $articled method" );
+ ok( $package->meta->has_method($name), "$package has $articled method" );
}
sub has_overridden_method {
+ my $package = shift;
+ my $name = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my $articled = A($name);
+ ok( $package->meta->has_method($name), "$package has $articled method" );
+
+ my $meth = $package->meta->get_method($name);
+ isa_ok( $meth, 'Moose::Meta::Method::Overridden' );
+}
+
+sub has_augmented_method {
my $class = shift;
my $name = shift;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
my $articled = A($name);
ok( $class->meta->has_method($name), "$class has $articled method" );
my $meth = $class->meta->get_method($name);
- isa_ok( $meth, 'Moose::Meta::Method::Overridden' );
+ isa_ok( $meth, 'Moose::Meta::Method::Augmented' );
+}
+
+sub requires_method {
+ my $package = shift;
+ my $method = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ ok(
+ $package->meta->requires_method($method),
+ "$package requires the method $method"
+ );
}
sub no_droppings {
- my $class = shift;
+ my $package = shift;
- ok( !$class->can('has'), "no Moose droppings in $class" );
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ ok( !$package->can('has'), "no Moose droppings in $package" );
+ ok( !$package->can('subtype'),
+ "no Moose::Util::TypeConstraints droppings in $package" );
}
sub is_immutable {
my $class = shift;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
ok( $class->meta->is_immutable, "$class has been made immutable" );
}
sub does_role {
- my $class = shift;
- my $role = shift;
+ my $package = shift;
+ my $role = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
- ok( $class->meta->does_role($role), "$class does the $role role" );
+ ok( $package->meta->does_role($role), "$package does the $role role" );
}
sub person01 {
last_name => 'Baggins',
);
- is( $person->full_name, 'Bilbo Baggins',
- 'full_name() is correctly implemented' );
+ is(
+ $person->full_name, 'Bilbo Baggins',
+ 'full_name() is correctly implemented'
+ );
+
+ $person = eval { Person->new( [ qw( Lisa Smith ) ] ) };
+
+ if ( my $e = $@ ) {
+ diag(
+ "Calling Person->new() with an array reference threw an error:\n$e"
+ );
+ BAIL_OUT(
+ 'You must implement Person->BUILDARGS correctly in order to continue these tests'
+ );
+ }
+ else {
+ ok( 1, 'Person->new() can accept an array reference as an argument' );
+ }
- $person = Person->new( [ qw( Lisa Smith ) ] );
is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' );
is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' );
- eval { Person->new( sub { 'foo' } ) };
- like( $@, qr/\QSingle parameters to new() must be a HASH ref/,
- 'Person constructor still rejects bad parameters' );
+ eval {
+ Person->new( sub {'foo'} );
+ };
+ like(
+ $@, qr/\QSingle parameters to new() must be a HASH ref/,
+ 'Person constructor still rejects bad parameters'
+ );
}
sub employee01 {
title => 'Singer',
);
- is( $employee->full_name, 'Amanda Palmer (Singer)', 'full_name() is properly overriden in Employee' );
+ my $called = 0;
+ my $orig_super = \&Employee::super;
+ no warnings 'redefine';
+ local *Employee::super = sub { $called++; goto &$orig_super };
+
+ is(
+ $employee->full_name, 'Amanda Palmer (Singer)',
+ 'full_name() is properly overriden in Employee'
+ );
+ ok( $called, 'Employee->full_name calls super()' );
}
sub person02 {
balance => 0,
);
- is( $person->as_string, 'Bilbo Baggins',
- 'as_string() is correctly implemented' );
+ is(
+ $person->as_string, 'Bilbo Baggins',
+ 'as_string() is correctly implemented'
+ );
account_tests($person);
}
balance => 0,
);
- is( $employee->as_string, 'Amanda Palmer (Singer)',
- 'as_string() uses overridden full_name method in Employee' );
+ is(
+ $employee->as_string, 'Amanda Palmer (Singer)',
+ 'as_string() uses overridden full_name method in Employee'
+ );
account_tests($employee);
}
last_name => 'Baggins',
);
- is( $person->full_name, 'Bilbo Baggins',
- 'full_name() is correctly implemented for a Person without a title' );
- ok( !$person->has_title,
- 'Person has_title predicate is working correctly' );
+ is(
+ $person->full_name, 'Bilbo Baggins',
+ 'full_name() is correctly implemented for a Person without a title'
+ );
+ ok(
+ !$person->has_title,
+ 'Person has_title predicate is working correctly (returns false)'
+ );
$person->title('Ringbearer');
- ok( $person->has_title, 'Person has_title predicate is working correctly' );
- is( $person->full_name, 'Bilbo Baggins (Ringbearer)',
- 'full_name() is correctly implemented for a Person with a title' );
+ ok( $person->has_title,
+ 'Person has_title predicate is working correctly (returns true)' );
+
+ my $called = 0;
+ my $orig_pred = \&Person::has_title;
+ no warnings 'redefine';
+ local *Person::has_title = sub { $called++; goto &$orig_pred };
+
+ is(
+ $person->full_name, 'Bilbo Baggins (Ringbearer)',
+ 'full_name() is correctly implemented for a Person with a title'
+ );
+ ok( $called,
+ 'full_name in person uses the predicate for the title attribute' );
$person->clear_title;
ok( !$person->has_title, 'Person clear_title method cleared the title' );
salary => 42,
);
- is( $employee->salary, 30000,
- 'salary is calculated from salary_level, and salary passed to constructor is ignored' );
-}
-
-
-sub person04 {
- my $person = Person->new(
- first_name => 'Bilbo',
- last_name => 'Baggins',
- );
-
- my $xml = <<'EOF';
-<?xml version="1.0" encoding="UTF-8"?>
-<Person>
-<first_name>Bilbo</first_name>
-<last_name>Baggins</last_name>
-<title></title>
-</Person>
-EOF
-
- is( $person->as_xml, $xml, 'Person outputs expected XML' );
-}
-
-sub employee04 {
- my $employee = Employee->new(
- first_name => 'Jimmy',
- last_name => 'Foo',
- ssn => '123-99-4567',
- salary_level => 3,
+ is(
+ $employee->salary, 30000,
+ 'salary is calculated from salary_level, and salary passed to constructor is ignored'
);
-
- my $xml = <<'EOF';
-<?xml version="1.0" encoding="UTF-8"?>
-<Employee>
-<first_name>Jimmy</first_name>
-<last_name>Foo</last_name>
-<title>Worker</title>
-<salary>30000</salary>
-<salary_level>3</salary_level>
-<ssn>123-99-4567</ssn>
-</Employee>
-EOF
-
- is( $employee->as_xml, $xml, 'Employee outputs expected XML' );
}
sub person06 {
);
isa_ok( $person->account, 'BankAccount' );
- is( $person->account->owner, $person,
- 'owner of bank account is person that created account' );
+ is(
+ $person->account->owner, $person,
+ 'owner of bank account is person that created account'
+ );
$person->deposit(10);
- is_deeply( $person->account->history, [ 100, 10 ],
- 'deposit was recorded in account history' );
+ is_deeply(
+ $person->account->history, [100],
+ 'deposit was recorded in account history'
+ );
$person->withdraw(15);
- is_deeply( $person->account->history, [ 100, 10, -15 ],
- 'withdrawal was recorded in account history' );
+ is_deeply(
+ $person->account->history, [ 100, 110 ],
+ 'withdrawal was recorded in account history'
+ );
+
+ $person->withdraw(45);
+ is_deeply(
+ $person->account->history, [ 100, 110, 95 ],
+ 'withdrawal was recorded in account history'
+ );
}
sub account_tests {
my $base_amount = shift || 0;
$person->deposit(50);
+
+ is(
+ $person->balance, 50 + $base_amount,
+ "balance is 50 + $base_amount",
+ );
+
eval { $person->withdraw( 75 + $base_amount ) };
- like( $@, qr/\QBalance cannot be negative/,
- 'cannot withdraw more than is in our balance' );
+ like(
+ $@, qr/\QBalance cannot be negative/,
+ 'cannot withdraw more than is in our balance'
+ );
- $person->withdraw( 23 );
+ $person->withdraw(23);
- is( $person->balance, 27 + $base_amount,
- 'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23' );
+ is(
+ $person->balance, 27 + $base_amount,
+ 'balance is 27 (+ starting balance) after deposit of 50 and withdrawal of 23'
+ );
}
1;
projects / gitmo/moose-presentations.git / blobdiff