local-lib5/lib/perl5/Moose/Cookbook/Basics/Recipe9.pod

   1
   2 =pod
   3
   4 =head1 NAME
   5
   6 Moose::Cookbook::Basics::Recipe9 - Operator overloading, subtypes, and coercion
   7
   8 =head1 SYNOPSIS
   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           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
  49 (well, the selection of genes at least).
  50
  51 =head1 INTRODUCTION
  52
  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.
  57
  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.
  62
  63 =head2 What is Operator Overloading?
  64
  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.
  70
  71 In this example we overload addition so we can write code like
  72 C<$child = $mother + $father>.
  73
  74 =head1 GENES
  75
  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.
  79
  80 =head2 Human::Gene::bey2
  81
  82   package Human::Gene::bey2;
  83
  84   use Moose;
  85   use Moose::Util::TypeConstraints;
  86
  87   type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} };
  88
  89   has 'color' => ( is => 'ro', isa => 'bey2_color' );
  90
  91 This class is trivial, We have a type constraint for the allowed
  92 colors, and a C<color> attribute.
  93
  94 =head2 Human::Gene::gey
  95
  96   package Human::Gene::gey;
  97
  98   use Moose;
  99   use Moose::Util::TypeConstraints;
 100
 101   type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} };
 102
 103   has 'color' => ( is => 'ro', isa => 'gey_color' );
 104
 105 This is nearly identical to the C<Humane::Gene::bey2> class, except
 106 that the I<gey> gene allows for different colors.
 107
 108 =head1 EYE COLOR
 109
 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.
 114
 115   package Human::EyeColor;
 116
 117   use Moose;
 118   use Moose::Util::TypeConstraints;
 119
 120   coerce 'Human::Gene::bey2'
 121       => from 'Str'
 122           => via { Human::Gene::bey2->new( color => $_ ) };
 123
 124   coerce 'Human::Gene::gey'
 125       => from 'Str'
 126           => via { Human::Gene::gey->new( color => $_ ) };
 127
 128   has [qw( bey2_1 bey2_2 )] =>
 129       ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 );
 130
 131   has [qw( gey_1 gey_2 )] =>
 132       ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 );
 133
 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.
 138
 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.
 146
 147   sub color {
 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
 158       return 'blue';
 159   }
 160
 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:
 163
 164   use overload '""' => \&color, fallback => 1;
 165
 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.
 169
 170   use overload '+' => \&_overload_add, fallback => 1;
 171
 172   sub _overload_add {
 173       my ( $one, $two ) = @_;
 174
 175       my $one_bey2 = 'bey2_' . _rand2();
 176       my $two_bey2 = 'bey2_' . _rand2();
 177
 178       my $one_gey = 'gey_' . _rand2();
 179       my $two_gey = 'gey_' . _rand2();
 180
 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   }
 188
 189   sub _rand2 {
 190       return 1 + int( rand(2) );
 191   }
 192
 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.
 197
 198 =head1 ADDING EYE COLOR TO C<Human>s
 199
 200 Our original C<Human> class requires just a few changes to incorporate
 201 our new C<Human::EyeColor> class.
 202
 203   use List::MoreUtils qw( zip );
 204
 205   coerce 'Human::EyeColor'
 206       => from 'ArrayRef'
 207       => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
 208                return Human::EyeColor->new( zip( @genes, @{$_} ) ); };
 209
 210   has 'eye_color' => (
 211       is       => 'ro',
 212       isa      => 'Human::EyeColor',
 213       coerce   => 1,
 214       required => 1,
 215   );
 216
 217 We also need to modify C<_overload_add()> in the C<Human> class to
 218 account for eye color:
 219
 220   return Human->new(
 221       gender    => $gender,
 222       eye_color => ( $one->eye_color() + $two->eye_color() ),
 223       mother    => $mother,
 224       father    => $father,
 225   );
 226
 227 =head1 CONCLUSION
 228
 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> pragma.
 234
 235 To see all the code we created together, take a look at
 236 F<t/000_recipes/basics/010_genes.t>.
 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
 256 =head1 AUTHORS
 257
 258 Aran Clary Deltac <bluefeet@cpan.org>
 259
 260 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 261
 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