lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod

   1 package Moose::Cookbook::Basics::Genome_OverloadingSubtypesAndCoercion;
   2
   3 # ABSTRACT: Operator overloading, subtypes, and coercion
   4
   5 __END__
   6
   7
   8 =pod
   9
  10 =head1 SYNOPSIS
  11
  12   package Human;
  13
  14   use Moose;
  15   use Moose::Util::TypeConstraints;
  16
  17   subtype 'Sex'
  18       => as 'Str'
  19       => where { $_ =~ m{^[mf]$}s };
  20
  21   has 'sex'    => ( is => 'ro', isa => 'Sex', 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->sex() eq $two->sex() );
  33
  34       my ( $mother, $father )
  35           = ( $one->sex eq 'f' ? ( $one, $two ) : ( $two, $one ) );
  36
  37       my $sex = 'f';
  38       $sex = 'm' if ( rand() >= 0.5 );
  39
  40       return Human->new(
  41           sex    => $sex,
  42           mother => $mother,
  43           father => $father,
  44       );
  45   }
  46
  47 =head1 DESCRIPTION
  48
  49 This Moose cookbook recipe shows how operator overloading, coercion,
  50 and subtypes can be used to mimic the human reproductive system
  51 (well, the selection of genes at least).
  52
  53 =head1 INTRODUCTION
  54
  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 sex. Remember, we're talking
  58 about biological reproduction, not marriage.
  59
  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.
  64
  65 =head2 What is Operator Overloading?
  66
  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.
  72
  73 In this example we overload addition so we can write code like
  74 C<$child = $mother + $father>.
  75
  76 =head1 GENES
  77
  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.
  81
  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 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 supplying 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 is 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' );
 155
 156       return 'green'
 157           if ( $self->gey_1->color() eq 'green'
 158           or $self->gey_2->color() eq 'green' );
 159
 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 two 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,
 217   );
 218
 219 We also need to modify C<_overload_add()> in the C<Human> class to
 220 account for eye color:
 221
 222   return Human->new(
 223       sex       => $sex,
 224       eye_color => ( $one->eye_color() + $two->eye_color() ),
 225       mother    => $mother,
 226       father    => $father,
 227   );
 228
 229 =head1 CONCLUSION
 230
 231 The three techniques we used, overloading, subtypes, and coercion,
 232 combine to provide a powerful interface.
 233
 234 If you'd like to learn more about overloading, please read the
 235 documentation for the L<overload> pragma.
 236
 237 To see all the code we created together, take a look at
 238 F<t/recipes/basics_recipe9.t>.
 239
 240 =head1 NEXT STEPS
 241
 242 Had this been a real project we'd probably want:
 243
 244 =over 4
 245
 246 =item Better Randomization with Crypt::Random
 247
 248 =item Characteristic Base Class
 249
 250 =item Mutating Genes
 251
 252 =item More Characteristics
 253
 254 =item Artificial Life
 255
 256 =back
 257
 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/>
 263
 264 =cut
 265