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