bacc8992cf38a467c4f11f03f5c79e32619779b0
[gitmo/Moose.git] / t / 002_recipes / basics_recipe10.t
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5
6 use Test::More;
7
8
9 {
10     package Human;
11
12     use Moose;
13     use Moose::Util::TypeConstraints;
14
15     subtype 'Gender'
16         => as 'Str'
17         => where { $_ =~ m{^[mf]$}s };
18
19     has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
20
21     has 'mother' => ( is => 'ro', isa => 'Human' );
22     has 'father' => ( is => 'ro', isa => 'Human' );
23
24     use overload '+' => \&_overload_add, fallback => 1;
25
26     sub _overload_add {
27         my ( $one, $two ) = @_;
28
29         die('Only male and female humans may create children')
30             if ( $one->gender() eq $two->gender() );
31
32         my ( $mother, $father )
33             = ( $one->gender eq 'f' ? ( $one, $two ) : ( $two, $one ) );
34
35         my $gender = 'f';
36         $gender = 'm' if ( rand() >= 0.5 );
37
38         return Human->new(
39             gender    => $gender,
40             eye_color => ( $one->eye_color() + $two->eye_color() ),
41             mother    => $mother,
42             father    => $father,
43         );
44     }
45
46     use List::MoreUtils qw( zip );
47
48     coerce 'Human::EyeColor'
49         => from 'ArrayRef'
50         => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
51                  return Human::EyeColor->new( zip( @genes, @{$_} ) ); };
52
53     has 'eye_color' => (
54         is       => 'ro',
55         isa      => 'Human::EyeColor',
56         coerce   => 1,
57         required => 1,
58     );
59
60 }
61
62 {
63     package Human::Gene::bey2;
64
65     use Moose;
66     use Moose::Util::TypeConstraints;
67
68     type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} };
69
70     has 'color' => ( is => 'ro', isa => 'bey2_color' );
71 }
72
73 {
74     package Human::Gene::gey;
75
76     use Moose;
77     use Moose::Util::TypeConstraints;
78
79     type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} };
80
81     has 'color' => ( is => 'ro', isa => 'gey_color' );
82 }
83
84 {
85     package Human::EyeColor;
86
87     use Moose;
88     use Moose::Util::TypeConstraints;
89
90     coerce 'Human::Gene::bey2'
91         => from 'Str'
92             => via { Human::Gene::bey2->new( color => $_ ) };
93
94     coerce 'Human::Gene::gey'
95         => from 'Str'
96             => via { Human::Gene::gey->new( color => $_ ) };
97
98     has [qw( bey2_1 bey2_2 )] =>
99         ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 );
100
101     has [qw( gey_1 gey_2 )] =>
102         ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 );
103
104     sub color {
105         my ($self) = @_;
106
107         return 'brown'
108             if ( $self->bey2_1->color() eq 'brown'
109             or $self->bey2_2->color() eq 'brown' );
110
111         return 'green'
112             if ( $self->gey_1->color() eq 'green'
113             or $self->gey_2->color() eq 'green' );
114
115         return 'blue';
116     }
117
118     use overload '""' => \&color, fallback => 1;
119
120     use overload '+' => \&_overload_add, fallback => 1;
121
122     sub _overload_add {
123         my ( $one, $two ) = @_;
124
125         my $one_bey2 = 'bey2_' . _rand2();
126         my $two_bey2 = 'bey2_' . _rand2();
127
128         my $one_gey = 'gey_' . _rand2();
129         my $two_gey = 'gey_' . _rand2();
130
131         return Human::EyeColor->new(
132             bey2_1 => $one->$one_bey2->color(),
133             bey2_2 => $two->$two_bey2->color(),
134             gey_1  => $one->$one_gey->color(),
135             gey_2  => $two->$two_gey->color(),
136         );
137     }
138
139     sub _rand2 {
140         return 1 + int( rand(2) );
141     }
142 }
143
144 my $gene_color_sets = [
145     [ qw( blue blue blue blue )     => 'blue' ],
146     [ qw( blue blue green blue )    => 'green' ],
147     [ qw( blue blue blue green )    => 'green' ],
148     [ qw( blue blue green green )   => 'green' ],
149     [ qw( brown blue blue blue )    => 'brown' ],
150     [ qw( brown brown green green ) => 'brown' ],
151     [ qw( blue brown green blue )   => 'brown' ],
152 ];
153
154 foreach my $set (@$gene_color_sets) {
155     my $expected_color = pop(@$set);
156
157     my $person = Human->new(
158         gender    => 'f',
159         eye_color => $set,
160     );
161
162     is(
163         $person->eye_color(),
164         $expected_color,
165         'gene combination '
166             . join( ',', @$set )
167             . ' produces '
168             . $expected_color
169             . ' eye color',
170     );
171 }
172
173 my $parent_sets = [
174     [
175         [qw( blue blue blue blue )],
176         [qw( blue blue blue blue )] => 'blue'
177     ],
178     [
179         [qw( blue blue blue blue )],
180         [qw( brown brown green blue )] => 'brown'
181     ],
182     [
183         [qw( blue blue green green )],
184         [qw( blue blue green green )] => 'green'
185     ],
186 ];
187
188 foreach my $set (@$parent_sets) {
189     my $expected_color = pop(@$set);
190
191     my $mother         = Human->new(
192         gender    => 'f',
193         eye_color => shift(@$set),
194     );
195
196     my $father = Human->new(
197         gender    => 'm',
198         eye_color => shift(@$set),
199     );
200
201     my $child = $mother + $father;
202
203     is(
204         $child->eye_color(),
205         $expected_color,
206         'mother '
207             . $mother->eye_color()
208             . ' + father '
209             . $father->eye_color()
210             . ' = child '
211             . $expected_color,
212     );
213 }
214
215 # Hmm, not sure how to test for random selection of genes since
216 # I could theoretically run an infinite number of iterations and
217 # never find proof that a child has inherited a particular gene.
218
219 # AUTHOR: Aran Clary Deltac <bluefeet@cpan.org>
220
221 done_testing;