Commit | Line | Data |
c2a0627f |
1 | |
2 | =pod |
3 | |
4 | =head1 NAME |
5 | |
58d129ba |
6 | Moose::Cookbook::Basics::Recipe10 - Operator overloading, subtypes, and coercion |
c2a0627f |
7 | |
8 | =head1 SYNOPSIS |
9 | |
10 | package Human; |
c765b254 |
11 | |
c2a0627f |
12 | use Moose; |
13 | use Moose::Util::TypeConstraints; |
c765b254 |
14 | |
c2a0627f |
15 | subtype 'Gender' |
16 | => as 'Str' |
17 | => where { $_ =~ m{^[mf]$}s }; |
c765b254 |
18 | |
c2a0627f |
19 | has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 ); |
c765b254 |
20 | |
c2a0627f |
21 | has 'mother' => ( is => 'ro', isa => 'Human' ); |
22 | has 'father' => ( is => 'ro', isa => 'Human' ); |
c765b254 |
23 | |
c2a0627f |
24 | use overload '+' => \&_overload_add, fallback => 1; |
c765b254 |
25 | |
c2a0627f |
26 | sub _overload_add { |
c765b254 |
27 | my ( $one, $two ) = @_; |
28 | |
c2a0627f |
29 | die('Only male and female humans may create children') |
c765b254 |
30 | if ( $one->gender() eq $two->gender() ); |
31 | |
32 | my ( $mother, $father ) |
33 | = ( $one->gender eq 'f' ? ( $one, $two ) : ( $two, $one ) ); |
34 | |
c2a0627f |
35 | my $gender = 'f'; |
c765b254 |
36 | $gender = 'm' if ( rand() >= 0.5 ); |
37 | |
c2a0627f |
38 | return Human->new( |
39 | gender => $gender, |
40 | mother => $mother, |
41 | father => $father, |
42 | ); |
43 | } |
44 | |
45 | =head1 DESCRIPTION |
46 | |
47 | This Moose cookbook recipe shows how operator overloading, coercion, |
48 | and sub types can be used to mimic the human reproductive system |
055dbe8c |
49 | (well, the selection of genes at least). |
c2a0627f |
50 | |
51 | =head1 INTRODUCTION |
52 | |
055dbe8c |
53 | Our C<Human> class uses operator overloading to allow us to "add" two |
54 | humans together and produce a child. Our implementation does require |
55 | that the two objects be of opposite genders. Remember, we're talking |
56 | about biological reproduction, not marriage. |
c2a0627f |
57 | |
055dbe8c |
58 | While this example works as-is, we can take it a lot further by adding |
59 | genes into the mix. We'll add the two genes that control eye color, |
60 | and use overloading to combine the genes from the parent to model the |
61 | biology. |
c2a0627f |
62 | |
055dbe8c |
63 | =head2 What is Operator Overloading? |
c2a0627f |
64 | |
055dbe8c |
65 | Overloading is I<not> a Moose-specific feature. It's a general OO |
66 | concept that is implemented in Perl with the C<overload> |
67 | pragma. Overloading lets objects do something sane when used with |
68 | Perl's built in operators, like addition (C<+>) or when used as a |
69 | string. |
c2a0627f |
70 | |
055dbe8c |
71 | In this example we overload addition so we can write code like |
72 | C<$child = $mother + $father>. |
c2a0627f |
73 | |
74 | =head1 GENES |
75 | |
055dbe8c |
76 | There are many genes which affect eye color, but there are two which |
77 | are most important, I<gey> and I<bey2>. We will start by making a |
78 | class for each gene. |
c2a0627f |
79 | |
055dbe8c |
80 | =head2 Human::Gene::bey2 |
c2a0627f |
81 | |
82 | package Human::Gene::bey2; |
c765b254 |
83 | |
c2a0627f |
84 | use Moose; |
85 | use Moose::Util::TypeConstraints; |
c765b254 |
86 | |
055dbe8c |
87 | type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} }; |
c765b254 |
88 | |
055dbe8c |
89 | has 'color' => ( is => 'ro', isa => 'bey2_color' ); |
c2a0627f |
90 | |
055dbe8c |
91 | This class is trivial, We have a type constraint for the allowed |
92 | colors, and a C<color> attribute. |
c2a0627f |
93 | |
055dbe8c |
94 | =head2 Human::Gene::gey |
c2a0627f |
95 | |
96 | package Human::Gene::gey; |
c765b254 |
97 | |
c2a0627f |
98 | use Moose; |
99 | use Moose::Util::TypeConstraints; |
c765b254 |
100 | |
055dbe8c |
101 | type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} }; |
c765b254 |
102 | |
055dbe8c |
103 | has 'color' => ( is => 'ro', isa => 'gey_color' ); |
c2a0627f |
104 | |
055dbe8c |
105 | This is nearly identical to the C<Humane::Gene::bey2> class, except |
106 | that the I<gey> gene allows for different colors. |
c2a0627f |
107 | |
108 | =head1 EYE COLOR |
109 | |
055dbe8c |
110 | We could just give add four attributes (two of each gene) to the |
111 | C<Human> class, but this is a bit messy. Instead, we'll abstract the |
112 | genes into a container class, C<Human::EyeColor>. Then a C<Human> can |
113 | have a single C<eye_color> attribute. |
c2a0627f |
114 | |
115 | package Human::EyeColor; |
c765b254 |
116 | |
c2a0627f |
117 | use Moose; |
118 | use Moose::Util::TypeConstraints; |
c765b254 |
119 | |
055dbe8c |
120 | coerce 'Human::Gene::bey2' |
c2a0627f |
121 | => from 'Str' |
122 | => via { Human::Gene::bey2->new( color => $_ ) }; |
c765b254 |
123 | |
055dbe8c |
124 | coerce 'Human::Gene::gey' |
c2a0627f |
125 | => from 'Str' |
126 | => via { Human::Gene::gey->new( color => $_ ) }; |
c765b254 |
127 | |
055dbe8c |
128 | has [qw( bey2_1 bey2_2 )] => |
129 | ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 ); |
c765b254 |
130 | |
055dbe8c |
131 | has [qw( gey_1 gey_2 )] => |
132 | ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 ); |
c2a0627f |
133 | |
055dbe8c |
134 | The eye color class has two of each type of gene. We've also created a |
135 | coercion for each class that coerces a string into a new object. Note |
136 | that a coercion will fail if it attempts to coerce a string like |
137 | "indigo", because that is not a valid color for either type of gene. |
c2a0627f |
138 | |
055dbe8c |
139 | As an aside, you can see that we can define several identical |
140 | attributes at once by supply an array reference of names as the first |
141 | argument to C<has>. |
142 | |
143 | We also need a method to calculate the actual eye color that results |
144 | from a set of genes. The I<bey2> brown gene is dominant over both blue |
145 | and green. The I<gey> green gene dominant over blue. |
c2a0627f |
146 | |
147 | sub color { |
c765b254 |
148 | my ($self) = @_; |
149 | |
150 | return 'brown' |
151 | if ( $self->bey2_1->color() eq 'brown' |
152 | or $self->bey2_2->color() eq 'brown' ); |
153 | |
154 | return 'green' |
155 | if ( $self->gey_1->color() eq 'green' |
156 | or $self->gey_2->color() eq 'green' ); |
157 | |
c2a0627f |
158 | return 'blue'; |
159 | } |
160 | |
055dbe8c |
161 | We'd like to be able to treat a C<Human::EyeColor> object as a string, |
162 | so we define a string overloading for the class: |
c2a0627f |
163 | |
164 | use overload '""' => \&color, fallback => 1; |
165 | |
055dbe8c |
166 | Finally, we need to define overloading for addition. That way we can |
167 | add together to C<Human::EyeColor> objects and get a new one with a |
168 | new (genetically correct) eye color. |
c2a0627f |
169 | |
170 | use overload '+' => \&_overload_add, fallback => 1; |
c765b254 |
171 | |
c2a0627f |
172 | sub _overload_add { |
c765b254 |
173 | my ( $one, $two ) = @_; |
174 | |
c2a0627f |
175 | my $one_bey2 = 'bey2_' . _rand2(); |
176 | my $two_bey2 = 'bey2_' . _rand2(); |
c765b254 |
177 | |
c2a0627f |
178 | my $one_gey = 'gey_' . _rand2(); |
179 | my $two_gey = 'gey_' . _rand2(); |
c765b254 |
180 | |
c2a0627f |
181 | return Human::EyeColor->new( |
182 | bey2_1 => $one->$one_bey2->color(), |
183 | bey2_2 => $two->$two_bey2->color(), |
184 | gey_1 => $one->$one_gey->color(), |
185 | gey_2 => $two->$two_gey->color(), |
186 | ); |
187 | } |
c765b254 |
188 | |
c2a0627f |
189 | sub _rand2 { |
190 | return 1 + int( rand(2) ); |
191 | } |
192 | |
055dbe8c |
193 | When two eye color objects are added together the C<_overload_add()> |
194 | method will be passed two C<Human::EyeColor> objects. These are the |
195 | left and right side operands for the C<+> operator. This method |
196 | returns a new C<Human::EyeColor> object. |
c2a0627f |
197 | |
055dbe8c |
198 | =head1 ADDING EYE COLOR TO C<Human>s |
c2a0627f |
199 | |
055dbe8c |
200 | Our original C<Human> class requires just a few changes to incorporate |
201 | our new C<Human::EyeColor> class. |
c2a0627f |
202 | |
203 | use List::MoreUtils qw( zip ); |
c765b254 |
204 | |
055dbe8c |
205 | coerce 'Human::EyeColor' |
c2a0627f |
206 | => from 'ArrayRef' |
c765b254 |
207 | => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 ); |
055dbe8c |
208 | return Human::EyeColor->new( zip( @genes, @{$_} ) ); }; |
c765b254 |
209 | |
055dbe8c |
210 | has 'eye_color' => ( |
211 | is => 'ro', |
212 | isa => 'Human::EyeColor', |
213 | coerce => 1, |
214 | required => 1, |
215 | ); |
c2a0627f |
216 | |
055dbe8c |
217 | We also need to modify C<_overload_add()> in the C<Human> class to |
218 | account for eye color: |
c2a0627f |
219 | |
220 | return Human->new( |
c765b254 |
221 | gender => $gender, |
c2a0627f |
222 | eye_color => ( $one->eye_color() + $two->eye_color() ), |
c765b254 |
223 | mother => $mother, |
224 | father => $father, |
c2a0627f |
225 | ); |
226 | |
227 | =head1 CONCLUSION |
228 | |
055dbe8c |
229 | The three techniques we used, overloading, subtypes, and coercion, |
230 | combine to provide a powerful interface. |
231 | |
232 | If you'd like to learn more about overloading, please read the |
233 | documentation for the L<overload> pragme. |
c2a0627f |
234 | |
055dbe8c |
235 | To see all the code we created together, take a look at |
6549b0d1 |
236 | F<t/000_recipes/basics/010_genes.t>. |
c2a0627f |
237 | |
238 | =head1 NEXT STEPS |
239 | |
240 | Has this been a real project we'd probably want to: |
241 | |
242 | =over 4 |
243 | |
244 | =item Better Randomization with Crypt::Random |
245 | |
246 | =item Characteristic Base Class |
247 | |
248 | =item Mutating Genes |
249 | |
250 | =item More Characteristics |
251 | |
252 | =item Artificial Life |
253 | |
254 | =back |
255 | |
055dbe8c |
256 | =head1 AUTHORS |
c2a0627f |
257 | |
258 | Aran Clary Deltac <bluefeet@cpan.org> |
259 | |
055dbe8c |
260 | Dave Rolsky E<lt>autarch@urth.orgE<gt> |
261 | |
c2a0627f |
262 | =head1 LICENSE |
263 | |
264 | This work is licensed under a Creative Commons Attribution 3.0 Unported License. |
265 | |
266 | License details are at: L<http://creativecommons.org/licenses/by/3.0/> |
267 | |
268 | =cut |
269 | |