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