Moose::Cookbook::Basics::Recipe10 - Operator overloading, subtypes, and coercion
package Human; use Moose; use Moose::Util::TypeConstraints; subtype 'Gender' => as 'Str' => where { $_ =~ m{^[mf]$}s }; has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 ); has 'mother' => ( is => 'ro', isa => 'Human' ); has 'father' => ( is => 'ro', isa => 'Human' ); use overload '+' => \&_overload_add, fallback => 1; sub _overload_add { my ($one, $two) = @_; die('Only male and female humans may create children') if ($one->gender() eq $two->gender()); my ( $mother, $father ) = ( $one->gender eq 'f' ? ($one, $two) : ($two, $one) ); my $gender = 'f'; $gender = 'm' if (rand() >= 0.5); return Human->new( gender => $gender, mother => $mother, father => $father, ); }
This Moose cookbook recipe shows how operator overloading, coercion, and sub types can be used to mimic the human reproductive system (well, the selection of genes at least). Assumes a basic understanding of Moose.
The example in the SYNOPSIS outlines a very basic use of operator overloading and Moose. The example creates a class that allows you to add together two humans and produce a child from them.
The two parents must be of the opposite gender, as to do otherwise wouldn't be biologically possible no matter how much I might want to allow it.
While this example works and gets the job done, it really isn't all that useful. To take this a step further let's play around with genes. Particularly the genes that dictate eye color. Why eye color? Because it is simple. There are two genes that have the most affect on eye color and each person carries two of each gene. Now that will be useful!
Oh, and don't forget that you were promised some coercion goodness.
First, let's quickly define the techniques that will be used.
Overloading operators takes a simple declaration of which operator you want to overload and what method to call. See the perldoc for overload to see some good, basic, examples.
Moose comes with 21 default type constraints, as documented in Moose::Util::TypeConstraints. Int, Str, and CodeRef are all examples. Subtypes give you the ability to inherit the constraints of an existing type, and adding additional constraints on that type. An introduction to type constraints is available in the Moose::Cookbook::Basics::Recipe4.
When an attribute is assigned a value its type constraint is checked to validate the value. Normally, if the value does not pass the constraint, an exception will be thrown. But, it is possible with Moose to define the rules to coerce values from one type to another. A good introduction to this can be found in Moose::Cookbook::Basics::Recipe5.
As I alluded to in the introduction, there are many different genes that affect eye color. But, there are 2 genes that play the most prominent role: gey and bey2. To get started let us make classes for these genes.
package Human::Gene::bey2; use Moose; use Moose::Util::TypeConstraints; type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s }; has 'color' => ( is => 'ro', isa => 'bey2Color' );
This class is really simple. All we need to know about the bey2 gene is whether it is of the blue or brown variety. As you can see a type constraint for the color attribute has been created which validates for the two possible colors.
package Human::Gene::gey; use Moose; use Moose::Util::TypeConstraints; type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s }; has 'color' => ( is => 'ro', isa => 'geyColor' );
The gey gene is nearly identical to the bey2, except that it has a green or blue variety.
Rather than throwing the 4 gene object (2xbey, 2xgey2) straight on to the Human class, let's create an intermediate class that abstracts the logic behind eye color. This way the Human class won't get all cluttered up with the details behind the different characteristics that makes up a Human.
package Human::EyeColor; use Moose; use Moose::Util::TypeConstraints; subtype 'bey2Gene' => as 'Object' => where { $_->isa('Human::Gene::bey2') }; coerce 'bey2Gene' => from 'Str' => via { Human::Gene::bey2->new( color => $_ ) }; subtype 'geyGene' => as 'Object' => where { $_->isa('Human::Gene::gey') }; coerce 'geyGene' => from 'Str' => via { Human::Gene::gey->new( color => $_ ) }; has 'bey2_1' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 ); has 'bey2_2' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 ); has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 ); has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
So, we now have a class that can hold the four genes that dictate eye color. This isn't quite enough, as we also need to calculate what the human's actual eye color is as a result of the genes.
As with most genes there are recessive and dominant genes. The bey2 brown gene is dominant to both blue and green. The gey green gene is recessive to the brown bey gene and dominant to the blues. Finally, the bey and gey2 blue genes are recessive to both brown and green.
sub color { my ( $self ) = @_; return 'brown' if ($self->bey2_1->color() eq 'brown' or $self->bey2_2->color() eq 'brown'); return 'green' if ($self->gey_1->color() eq 'green' or $self->gey_2->color() eq 'green'); return 'blue'; }
To top it off, if I want to access color(), I want to be really lazy about it. Perl overloading supports the ability to overload the stringification of an object. So, normally if I did "$eye_color" I'd get something like "Human::EyeColor=HASH(0xba9348)". What I really want is "brown", "green", or "blue". To do this you overload the stringification of the object.
use overload '""' => \&color, fallback => 1;
That's all and good, but don't forget the spawn! Our humans have to have children, and those children need to inherit genes from their parents. Let's use operator overloading so that we can add (+) together two EyeColor characteristics to create a new EyeColor that is derived in a similar manner as the gene selection in human reproduction.
use overload '+' => \&_overload_add, fallback => 1; sub _overload_add { my ($one, $two) = @_; my $one_bey2 = 'bey2_' . _rand2(); my $two_bey2 = 'bey2_' . _rand2(); my $one_gey = 'gey_' . _rand2(); my $two_gey = 'gey_' . _rand2(); return Human::EyeColor->new( bey2_1 => $one->$one_bey2->color(), bey2_2 => $two->$two_bey2->color(), gey_1 => $one->$one_gey->color(), gey_2 => $two->$two_gey->color(), ); } sub _rand2 { return 1 + int( rand(2) ); }
What is happening here is we are overloading the addition operator. When two eye color objects are added together the _overload_add() method will be called with the two objects on the left and right side of the + as arguments. The return value of this method should be the expected result of the addition. I'm not going to go in to the details of how the gene's are selected as it should be fairly self-explanatory.
Our original human class in the SYNOPSIS requires very little change to support the new EyeColor characteristic. All we need to do is define a new subtype called EyeColor, a new attribute called eye_color, and just for the sake of simple code we'll coerce an arrayref of colors in to an EyeColor object.
use List::MoreUtils qw( zip ); subtype 'EyeColor' => as 'Object' => where { $_->isa('Human::EyeColor') }; coerce 'EyeColor' => from 'ArrayRef' => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 ); return Human::EyeColor->new( zip( @genes, @$_ ) ); }; has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
And then in the _overload_add() of the Human class we modify the creation of the child object to include the addition of the mother and father's eye colors.
return Human->new( gender => $gender, eye_color => ( $one->eye_color() + $two->eye_color() ), mother => $mother, father => $father, );
The three techniques used in this article - overloading, subtypes, and coercion - provide the power to produce simple, flexible, powerful, explicit, inheritable, and enjoyable interfaces.
If you want to get your hands on this code all combined together, and working, download the Moose tarball and look at "t/000_recipes/012_genes.t".
Has this been a real project we'd probably want to:
Aran Clary Deltac <bluefeet@cpan.org>
This work is licensed under a Creative Commons Attribution 3.0 Unported License.
License details are at: http://creativecommons.org/licenses/by/3.0/
To install Moose, copy and paste the appropriate command in to your terminal.
cpanm
cpanm Moose
CPAN shell
perl -MCPAN -e shell install Moose
For more information on module installation, please visit the detailed CPAN module installation guide.