--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+BEGIN{
+ eval 'use Regexp::Common; use Locale::US;';
+ if ($@) {
+ plan skip_all => 'Regexp::Common & Locale::US required for this test';
+ }
+ else{
+ plan 'no_plan';
+ }
+}
+
+use Test::Exception;
+$| = 1;
+
+
+
+# =begin testing SETUP
+BEGIN {
+ eval 'use Regexp::Common; use Locale::US;';
+ if ($@) {
+ plan skip_all => 'Regexp::Common & Locale::US required for this test';
+ }
+}
+
+
+
+# =begin testing SETUP
+{
+
+ package Address;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ use Locale::US;
+ use Regexp::Common 'zip';
+
+ my $STATES = Locale::US->new;
+ subtype 'USState'
+ => as Str
+ => where {
+ ( exists $STATES->{code2state}{ uc($_) }
+ || exists $STATES->{state2code}{ uc($_) } );
+ };
+
+ subtype 'USZipCode'
+ => as Value
+ => where {
+ /^$RE{zip}{US}{-extended => 'allow'}$/;
+ };
+
+ has 'street' => ( is => 'rw', isa => 'Str' );
+ has 'city' => ( is => 'rw', isa => 'Str' );
+ has 'state' => ( is => 'rw', isa => 'USState' );
+ has 'zip_code' => ( is => 'rw', isa => 'USZipCode' );
+
+ package Company;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ has 'name' => ( is => 'rw', isa => 'Str', required => 1 );
+ has 'address' => ( is => 'rw', isa => 'Address' );
+ has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]' );
+
+ sub BUILD {
+ my ( $self, $params ) = @_;
+ if ( @{ $self->employees || [] } ) {
+ foreach my $employee ( @{ $self->employees } ) {
+ $employee->employer($self);
+ }
+ }
+ }
+
+ after 'employees' => sub {
+ my ( $self, $employees ) = @_;
+ if ($employees) {
+ foreach my $employee ( @{$employees} ) {
+ $employee->employer($self);
+ }
+ }
+ };
+
+ package Person;
+ use Mouse;
+
+ has 'first_name' => ( is => 'rw', isa => 'Str', required => 1 );
+ has 'last_name' => ( is => 'rw', isa => 'Str', required => 1 );
+ has 'middle_initial' => (
+ is => 'rw', isa => 'Str',
+ predicate => 'has_middle_initial'
+ );
+ has 'address' => ( is => 'rw', isa => 'Address' );
+
+ sub full_name {
+ my $self = shift;
+ return $self->first_name
+ . (
+ $self->has_middle_initial
+ ? ' ' . $self->middle_initial . '. '
+ : ' '
+ ) . $self->last_name;
+ }
+
+ package Employee;
+ use Mouse;
+
+ extends 'Person';
+
+ has 'title' => ( is => 'rw', isa => 'Str', required => 1 );
+ has 'employer' => ( is => 'rw', isa => 'Company', weak_ref => 1 );
+
+ override 'full_name' => sub {
+ my $self = shift;
+ super() . ', ' . $self->title;
+ };
+}
+
+
+
+# =begin testing
+{
+{
+ package Company;
+
+ sub get_employee_count { scalar @{(shift)->employees} }
+}
+
+use Scalar::Util 'isweak';
+
+my $ii;
+lives_ok {
+ $ii = Company->new(
+ {
+ name => 'Infinity Interactive',
+ address => Address->new(
+ street => '565 Plandome Rd., Suite 307',
+ city => 'Manhasset',
+ state => 'NY',
+ zip_code => '11030'
+ ),
+ employees => [
+ Employee->new(
+ first_name => 'Jeremy',
+ last_name => 'Shao',
+ title => 'President / Senior Consultant',
+ address =>
+ Address->new( city => 'Manhasset', state => 'NY' )
+ ),
+ Employee->new(
+ first_name => 'Tommy',
+ last_name => 'Lee',
+ title => 'Vice President / Senior Developer',
+ address =>
+ Address->new( city => 'New York', state => 'NY' )
+ ),
+ Employee->new(
+ first_name => 'Stevan',
+ middle_initial => 'C',
+ last_name => 'Little',
+ title => 'Senior Developer',
+ address =>
+ Address->new( city => 'Madison', state => 'CT' )
+ ),
+ ]
+ }
+ );
+}
+'... created the entire company successfully';
+isa_ok( $ii, 'Company' );
+
+is( $ii->name, 'Infinity Interactive',
+ '... got the right name for the company' );
+
+isa_ok( $ii->address, 'Address' );
+is( $ii->address->street, '565 Plandome Rd., Suite 307',
+ '... got the right street address' );
+is( $ii->address->city, 'Manhasset', '... got the right city' );
+is( $ii->address->state, 'NY', '... got the right state' );
+is( $ii->address->zip_code, 11030, '... got the zip code' );
+
+is( $ii->get_employee_count, 3, '... got the right employee count' );
+
+# employee #1
+
+isa_ok( $ii->employees->[0], 'Employee' );
+isa_ok( $ii->employees->[0], 'Person' );
+
+is( $ii->employees->[0]->first_name, 'Jeremy',
+ '... got the right first name' );
+is( $ii->employees->[0]->last_name, 'Shao', '... got the right last name' );
+ok( !$ii->employees->[0]->has_middle_initial, '... no middle initial' );
+is( $ii->employees->[0]->middle_initial, undef,
+ '... got the right middle initial value' );
+is( $ii->employees->[0]->full_name,
+ 'Jeremy Shao, President / Senior Consultant',
+ '... got the right full name' );
+is( $ii->employees->[0]->title, 'President / Senior Consultant',
+ '... got the right title' );
+is( $ii->employees->[0]->employer, $ii, '... got the right company' );
+ok( isweak( $ii->employees->[0]->{employer} ),
+ '... the company is a weak-ref' );
+
+isa_ok( $ii->employees->[0]->address, 'Address' );
+is( $ii->employees->[0]->address->city, 'Manhasset',
+ '... got the right city' );
+is( $ii->employees->[0]->address->state, 'NY', '... got the right state' );
+
+# employee #2
+
+isa_ok( $ii->employees->[1], 'Employee' );
+isa_ok( $ii->employees->[1], 'Person' );
+
+is( $ii->employees->[1]->first_name, 'Tommy',
+ '... got the right first name' );
+is( $ii->employees->[1]->last_name, 'Lee', '... got the right last name' );
+ok( !$ii->employees->[1]->has_middle_initial, '... no middle initial' );
+is( $ii->employees->[1]->middle_initial, undef,
+ '... got the right middle initial value' );
+is( $ii->employees->[1]->full_name,
+ 'Tommy Lee, Vice President / Senior Developer',
+ '... got the right full name' );
+is( $ii->employees->[1]->title, 'Vice President / Senior Developer',
+ '... got the right title' );
+is( $ii->employees->[1]->employer, $ii, '... got the right company' );
+ok( isweak( $ii->employees->[1]->{employer} ),
+ '... the company is a weak-ref' );
+
+isa_ok( $ii->employees->[1]->address, 'Address' );
+is( $ii->employees->[1]->address->city, 'New York',
+ '... got the right city' );
+is( $ii->employees->[1]->address->state, 'NY', '... got the right state' );
+
+# employee #3
+
+isa_ok( $ii->employees->[2], 'Employee' );
+isa_ok( $ii->employees->[2], 'Person' );
+
+is( $ii->employees->[2]->first_name, 'Stevan',
+ '... got the right first name' );
+is( $ii->employees->[2]->last_name, 'Little', '... got the right last name' );
+ok( $ii->employees->[2]->has_middle_initial, '... got middle initial' );
+is( $ii->employees->[2]->middle_initial, 'C',
+ '... got the right middle initial value' );
+is( $ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer',
+ '... got the right full name' );
+is( $ii->employees->[2]->title, 'Senior Developer',
+ '... got the right title' );
+is( $ii->employees->[2]->employer, $ii, '... got the right company' );
+ok( isweak( $ii->employees->[2]->{employer} ),
+ '... the company is a weak-ref' );
+
+isa_ok( $ii->employees->[2]->address, 'Address' );
+is( $ii->employees->[2]->address->city, 'Madison', '... got the right city' );
+is( $ii->employees->[2]->address->state, 'CT', '... got the right state' );
+
+# create new company
+
+my $new_company
+ = Company->new( name => 'Infinity Interactive International' );
+isa_ok( $new_company, 'Company' );
+
+my $ii_employees = $ii->employees;
+foreach my $employee (@$ii_employees) {
+ is( $employee->employer, $ii, '... has the ii company' );
+}
+
+$new_company->employees($ii_employees);
+
+foreach my $employee ( @{ $new_company->employees } ) {
+ is( $employee->employer, $new_company,
+ '... has the different company now' );
+}
+
+## check some error conditions for the subtypes
+
+dies_ok {
+ Address->new( street => {} ),;
+}
+'... we die correctly with bad args';
+
+dies_ok {
+ Address->new( city => {} ),;
+}
+'... we die correctly with bad args';
+
+dies_ok {
+ Address->new( state => 'British Columbia' ),;
+}
+'... we die correctly with bad args';
+
+lives_ok {
+ Address->new( state => 'Connecticut' ),;
+}
+'... we live correctly with good args';
+
+dies_ok {
+ Address->new( zip_code => 'AF5J6$' ),;
+}
+'... we die correctly with bad args';
+
+lives_ok {
+ Address->new( zip_code => '06443' ),;
+}
+'... we live correctly with good args';
+
+dies_ok {
+ Company->new(),;
+}
+'... we die correctly without good args';
+
+lives_ok {
+ Company->new( name => 'Foo' ),;
+}
+'... we live correctly without good args';
+
+dies_ok {
+ Company->new( name => 'Foo', employees => [ Person->new ] ),;
+}
+'... we die correctly with good args';
+
+lives_ok {
+ Company->new( name => 'Foo', employees => [] ),;
+}
+'... we live correctly with good args';
+}
+
+
+
+
+1;
projects / gitmo/Mouse.git / blobdiff