use warnings;
use Lingua::EN::Inflect qw( A PL_N );
+use Scalar::Util qw( blessed );
use Test::More 'no_plan';
sub tests01 {
no_droppings('Person');
is_immutable('Person');
+
+ no_droppings('Employee');
+ is_immutable('Employee');
}
sub tests02 {
sub tests03 {
has_meta('Person');
- has_meta('Employee');
-
- has_rw_attr( 'Person', 'title' );
- has_rw_attr( 'Employee', 'title', 'overridden' );
- 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' );
'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(
'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 {
- has_meta('Document');
- has_meta('Report');
- has_meta('TPSReport');
-
- no_droppings('Document');
- no_droppings('Report');
- no_droppings('TPSReport');
-
- has_ro_attr( 'Document', $_ ) for qw( title author );
- has_ro_attr( 'Report', 'summary' );
- has_ro_attr( 'TPSReport', $_ ) for qw( t p s );
-
- has_method( 'Document', 'output' );
- has_augmented_method( 'Report', 'output' );
- has_augmented_method( 'TPSReport', 'output' );
-
- my $tps = TPSReport->new(
- title => 'That TPS Report',
- author => 'Peter Gibbons (for Bill Lumberg)',
- summary => 'I celebrate his whole collection!',
- t => 'PC Load Letter',
- p => 'Swingline',
- s => 'flair!',
- );
-
- my $output = $tps->output;
- $output =~ s/\n\n+/\n/g;
-
- is( $output, <<'EOF', 'output returns expected report' );
-That TPS Report
-I celebrate his whole collection!
-t: PC Load Letter
-p: Swingline
-s: flair!
-Written by Peter Gibbons (for Bill Lumberg)
-EOF
+ has_meta('Person');
+
+ 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'
+ );
+
+ 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');
- has_meta('Employee');
- no_droppings('Employee');
for my $attr_name (qw( first_name last_name title )) {
my $attr = Person->meta->get_attribute($attr_name);
);
}
+ has_meta('Employee');
+
{
my $salary_level_attr = Employee->meta->get_attribute('salary_level');
ok(
);
}
}
+
+ no_droppings('Employee');
}
sub tests06 {
- has_meta('Person');
- has_meta('Employee');
has_meta('BankAccount');
- no_droppings('BankAccount');
- has_rw_attr( 'BankAccount', 'balance' );
- has_rw_attr( 'BankAccount', 'owner' );
- has_ro_attr( 'BankAccount', 'history' );
+ has_rw_attr( 'BankAccount', $_ ) for qw( balance owner );
my $ba_meta = BankAccount->meta;
+
ok(
- $ba_meta->has_attribute('balance'),
- 'BankAccount class has a balance attribute'
+ $ba_meta->get_attribute('owner')->is_weak_ref,
+ 'owner attribute is a weak ref'
);
+ 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()
+ $history_attr->meta()->can('does_role')
+ && $history_attr->meta()
->does_role('Moose::Meta::Attribute::Native::Trait::Array'),
'BankAccount history attribute uses native delegation to an array ref'
);
'BankAccount balance attribute has a trigger'
);
+ has_meta('Person');
+
my $person_meta = Person->meta;
+
+ 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_isa_ok(
+ $deposit_meth, 'Moose::Meta::Method::Delegation',
+ 'The Person->deposit method exists and is a delegation method'
+ );
my $withdraw_meth = $person_meta->get_method('withdraw');
- isa_ok( $withdraw_meth, 'Moose::Meta::Method::Delegation' );
-
- ok(
- $ba_meta->get_attribute('owner')->is_weak_ref,
- 'owner attribute is a weak ref'
+ _my_isa_ok(
+ $withdraw_meth, 'Moose::Meta::Method::Delegation',
+ 'The Person->withdraw method exists and is a delegation method'
);
person06();
+
+ has_meta('Employee');
+
+ no_droppings('BankAccount');
}
sub has_meta {
local $Test::Builder::Level = $Test::Builder::Level + 1;
- use_ok($package)
- or BAIL_OUT("$package cannot be loaded");
+ {
+ my @warn;
+ local $SIG{__WARN__} = sub { push @warn, @_ };
+
+ use_ok($package)
+ or BAIL_OUT("$package cannot be loaded");
+
+ BAIL_OUT("Warning when loading $package: @warn")
+ if @warn;
+ }
ok( $package->can('meta'), "$package has a meta() method" )
or BAIL_OUT(
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::Augmented' );
+ _my_isa_ok(
+ $meth, 'Moose::Meta::Method::Overridden',
+ "The $name method is an overridden method"
+ );
}
sub requires_method {
);
$person = eval { Person->new( [ qw( Lisa Smith ) ] ) };
- ok( !$@, 'Person->new() can accept an array reference as an argument' )
- or BAIL_OUT(
- 'You must implement Person->BUILDARGS in order to continue these tests'
+
+ 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' );
+ }
is( $person->first_name, 'Lisa', 'set first_name from two-arg arrayref' );
is( $person->last_name, 'Smith', 'set last_name from two-arg arrayref' );
}
sub person06 {
+ my $account = BankAccount->new();
+
my $person = Person->new(
first_name => 'Bilbo',
last_name => 'Baggins',
+ account => $account,
+ );
+
+ is(
+ $person->account, $account,
+ 'account object passed to Person->new is still in object'
+ );
+
+ _my_isa_ok(
+ $person->account, 'BankAccount',
+ 'The value of $person->account() isa BankAccount object'
);
- isa_ok( $person->account, 'BankAccount' );
is(
$person->account->owner, $person,
'owner of bank account is person that created account'
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/,
);
}
+sub _my_isa_ok {
+ my $thing = shift;
+ my $class = shift;
+ my $desc = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ ok(
+ $thing && ( blessed $thing || !ref $thing ) && $thing->isa($class),
+ $desc
+ );
+}
+
1;
projects / gitmo/moose-presentations.git / blobdiff