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.
+(well, the selection of genes at least).
=head1 INTRODUCTION
-The example in the L</"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.
+Our C<Human> class uses operator overloading to allow us to "add" two
+humans together and produce a child. Our implementation does require
+that the two objects be of opposite genders. Remember, we're talking
+about biological reproduction, not marriage.
-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 as-is, we can take it a lot further by adding
+genes into the mix. We'll add the two genes that control eye color,
+and use overloading to combine the genes from the parent to model the
+biology.
-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 effect on eye color and each person carries two of each
-gene. Now that will be useful!
+=head2 What is Operator Overloading?
-Oh, and don't forget that you were promised some coercion goodness.
+Overloading is I<not> a Moose-specific feature. It's a general OO
+concept that is implemented in Perl with the C<overload>
+pragma. Overloading lets objects do something sane when used with
+Perl's built in operators, like addition (C<+>) or when used as a
+string.
-=head1 TECHNIQUES
-
-First, let's quickly define the techniques that will be used.
-
-=head2 Operator Overloading
-
-Overloading operators takes a simple declaration of which operator
-you want to overload and what method to call. See
-L<overload> to see some good, basic, examples.
-
-=head2 Subtypes
-
-Moose comes with 21 default type constraints, as documented in
-L<Moose::Util::TypeConstraints>. C<Int>, C<Str>, and C<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 L<Moose::Cookbook::Basics::Recipe4>.
-
-=head2 Coercion
-
-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 L<Moose::Cookbook::Basics::Recipe5>.
+In this example we overload addition so we can write code like
+C<$child = $mother + $father>.
=head1 GENES
-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: I<gey> and I<bey2>. To get started let us
-make classes for these genes.
+There are many genes which affect eye color, but there are two which
+are most important, I<gey> and I<bey2>. We will start by making a
+class for each gene.
-=head2 bey2
+=head2 Human::Gene::bey2
package Human::Gene::bey2;
use Moose;
use Moose::Util::TypeConstraints;
- type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s };
+ type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} };
- has 'color' => ( is => 'ro', isa => 'bey2Color' );
+ has 'color' => ( is => 'ro', isa => 'bey2_color' );
-This class is really simple. All we need to know about the I<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.
+This class is trivial, We have a type constraint for the allowed
+colors, and a C<color> attribute.
-=head2 gey
+=head2 Human::Gene::gey
package Human::Gene::gey;
use Moose;
use Moose::Util::TypeConstraints;
- type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s };
+ type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} };
- has 'color' => ( is => 'ro', isa => 'geyColor' );
+ has 'color' => ( is => 'ro', isa => 'gey_color' );
-The I<gey> gene is nearly identical to I<bey2>, except that it
-has a green or blue variety.
+This is nearly identical to the C<Humane::Gene::bey2> class, except
+that the I<gey> gene allows for different colors.
=head1 EYE COLOR
-Rather than throwing the 4 gene object (2 x I<bey>, 2 x I<gey2>) straight
-on to the C<Human> class, let's create an intermediate class that
-abstracts the logic behind eye color. This way the C<Human> class
-won't get all cluttered up with the details behind the different
-characteristics that makes up a Human.
+We could just give add four attributes (two of each gene) to the
+C<Human> class, but this is a bit messy. Instead, we'll abstract the
+genes into a container class, C<Human::EyeColor>. Then a C<Human> can
+have a single C<eye_color> attribute.
package Human::EyeColor;
use Moose;
use Moose::Util::TypeConstraints;
- subtype 'bey2Gene'
- => as 'Object'
- => where { $_->isa('Human::Gene::bey2') };
-
- coerce 'bey2Gene'
+ coerce 'Human::Gene::bey2'
=> from 'Str'
=> via { Human::Gene::bey2->new( color => $_ ) };
- subtype 'geyGene'
- => as 'Object'
- => where { $_->isa('Human::Gene::gey') };
-
- coerce 'geyGene'
+ coerce 'Human::Gene::gey'
=> 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 [qw( bey2_1 bey2_2 )] =>
+ ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 );
- has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
- has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
+ has [qw( gey_1 gey_2 )] =>
+ ( is => 'ro', isa => 'Human::Gene::gey', 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.
+The eye color class has two of each type of gene. We've also created a
+coercion for each class that coerces a string into a new object. Note
+that a coercion will fail if it attempts to coerce a string like
+"indigo", because that is not a valid color for either type of gene.
-As with most genes there are recessive and dominant genes. The I<bey2>
-brown gene is dominant to both blue and green. The I<gey> green gene is
-recessive to the brown I<bey> gene and dominant to the blues. Finally,
-the I<bey> and I<gey2> blue genes are recessive to both brown and green.
+As an aside, you can see that we can define several identical
+attributes at once by supply an array reference of names as the first
+argument to C<has>.
+
+We also need a method to calculate the actual eye color that results
+from a set of genes. The I<bey2> brown gene is dominant over both blue
+and green. The I<gey> green gene dominant over blue.
sub color {
my ($self) = @_;
return 'blue';
}
-To top it off, if I want to access C<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 C<$eye_color>
-I'd get something like C<Human::EyeColor=HASH(0xba9348)>. What I
-really want is "brown", "green", or "blue". To do this you overload
-the stringification of the object.
+We'd like to be able to treat a C<Human::EyeColor> object as a string,
+so we define a string overloading for the class:
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 C<EyeColor> characteristics to
-create a new C<EyeColor> that is derived in a similar manner as
-the gene selection in human reproduction.
+Finally, we need to define overloading for addition. That way we can
+add together to C<Human::EyeColor> objects and get a new one with a
+new (genetically correct) eye color.
use overload '+' => \&_overload_add, fallback => 1;
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 C<_overload_add()> method will be called with the two
-objects on the left and right side of the C<+> 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.
+When two eye color objects are added together the C<_overload_add()>
+method will be passed two C<Human::EyeColor> objects. These are the
+left and right side operands for the C<+> operator. This method
+returns a new C<Human::EyeColor> object.
-=head1 HUMAN EVOLUTION
+=head1 ADDING EYE COLOR TO C<Human>s
-Our original human class in the L</"SYNOPSIS"> requires very little
-change to support the new C<EyeColor> characteristic. All we
-need to do is define a new subtype called C<EyeColor>, a new
-attribute called C<eye_color>, and just for the sake of simple code
-we'll coerce an arrayref of colors in to an C<EyeColor> object.
+Our original C<Human> class requires just a few changes to incorporate
+our new C<Human::EyeColor> class.
use List::MoreUtils qw( zip );
- subtype 'EyeColor'
- => as 'Object'
- => where { $_->isa('Human::EyeColor') };
-
- coerce 'EyeColor'
+ coerce 'Human::EyeColor'
=> from 'ArrayRef'
=> via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
- return Human::EyeColor->new( zip( @genes, @$_ ) ); };
+ return Human::EyeColor->new( zip( @genes, @{$_} ) ); };
- has 'eye_color' =>
- ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
+ has 'eye_color' => (
+ is => 'ro',
+ isa => 'Human::EyeColor',
+ coerce => 1,
+ required => 1,
+ );
-And then in the C<_overload_add()> of the C<Human> class we modify
-the creation of the child object to include the addition of
-the mother and father's eye colors.
+We also need to modify C<_overload_add()> in the C<Human> class to
+account for eye color:
return Human->new(
gender => $gender,
=head1 CONCLUSION
-The three techniques used in this article - overloading, subtypes,
-and coercion - provide the power to produce simple, flexible, powerful,
-explicit, inheritable, and enjoyable interfaces.
+The three techniques we used, overloading, subtypes, and coercion,
+combine to provide a powerful interface.
+
+If you'd like to learn more about overloading, please read the
+documentation for the L<overload> pragme.
-If you want to get your hands on this code all combined together, and
-working, download the Moose tarball and look at
+To see all the code we created together, take a look at
F<t/000_recipes/basics/010_genes.t>.
=head1 NEXT STEPS
=back
-=head1 AUTHOR
+=head1 AUTHORS
Aran Clary Deltac <bluefeet@cpan.org>
+Dave Rolsky E<lt>autarch@urth.orgE<gt>
+
=head1 LICENSE
This work is licensed under a Creative Commons Attribution 3.0 Unported License.
use strict;
use warnings;
+use Test::More tests => 10;
+
+
{
package Human;
use Moose;
use Moose::Util::TypeConstraints;
- subtype 'EyeColor'
- => as 'Object'
- => where { $_->isa('Human::EyeColor') };
-
- coerce 'EyeColor'
- => from 'ArrayRef'
- => via {
- return Human::EyeColor->new(
- bey2_1 => $_->[0],
- bey2_2 => $_->[1],
- gey_1 => $_->[2],
- gey_2 => $_->[3],
- );
- };
-
subtype 'Gender'
=> as 'Str'
=> where { $_ =~ m{^[mf]$}s };
has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
- has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, 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) = @_;
+ my ( $one, $two ) = @_;
- die('Only male and female humans may have children')
- if ($one->gender() eq $two->gender());
+ 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 ( $mother, $father )
+ = ( $one->gender eq 'f' ? ( $one, $two ) : ( $two, $one ) );
my $gender = 'f';
- $gender = 'm' if (rand() >= 0.5);
-
- # Would be better to use Crypt::Random.
- #use Crypt::Random qw( makerandom );
- #$gender = 'm' if (makerandom( Size => 1, Strength => 1, Uniform => 1 ));
+ $gender = 'm' if ( rand() >= 0.5 );
return Human->new(
- gender => $gender,
+ gender => $gender,
eye_color => ( $one->eye_color() + $two->eye_color() ),
- mother => $mother,
- father => $father,
+ mother => $mother,
+ father => $father,
);
}
+
+ use List::MoreUtils qw( zip );
+
+ coerce 'Human::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 => 'Human::EyeColor',
+ coerce => 1,
+ required => 1,
+ );
+
}
{
- package Human::EyeColor;
+ package Human::Gene::bey2;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} };
+
+ has 'color' => ( is => 'ro', isa => 'bey2_color' );
+}
+
+{
+ package Human::Gene::gey;
use Moose;
use Moose::Util::TypeConstraints;
- subtype 'bey2Gene'
- => as 'Object'
- => where { $_->isa('Human::Gene::bey2') };
+ type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} };
+
+ has 'color' => ( is => 'ro', isa => 'gey_color' );
+}
- coerce 'bey2Gene'
+{
+ package Human::EyeColor;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ coerce 'Human::Gene::bey2'
=> from 'Str'
=> via { Human::Gene::bey2->new( color => $_ ) };
- subtype 'geyGene'
- => as 'Object'
- => where { $_->isa('Human::Gene::gey') };
-
- coerce 'geyGene'
+ coerce 'Human::Gene::gey'
=> 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 );
+ has [qw( bey2_1 bey2_2 )] =>
+ ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 );
- use overload '+' => \&_overload_add, fallback => 1;
- use overload '""' => \&color, fallback => 1;
+ has [qw( gey_1 gey_2 )] =>
+ ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 );
sub color {
- my ( $self ) = @_;
+ 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 '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';
}
+ use overload '""' => \&color, fallback => 1;
+
+ use overload '+' => \&_overload_add, fallback => 1;
+
sub _overload_add {
- my ($one, $two) = @_;
+ my ( $one, $two ) = @_;
my $one_bey2 = 'bey2_' . _rand2();
my $two_bey2 = 'bey2_' . _rand2();
}
sub _rand2 {
- # Would be better to use Crypt::Random.
- #use Crypt::Random qw( makerandom );
- #return 1 + makerandom( Size => 1, Strength => 1, Uniform => 1 );
return 1 + int( rand(2) );
}
}
-{
- package Human::Gene::bey2;
-
- use Moose;
- use Moose::Util::TypeConstraints;
-
- type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s };
-
- has 'color' => ( is => 'ro', isa => 'bey2Color' );
-}
-
-{
- package Human::Gene::gey;
-
- use Moose;
- use Moose::Util::TypeConstraints;
-
- type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s };
-
- has 'color' => ( is => 'ro', isa => 'geyColor' );
-}
-
-use Test::More tests => 10;
-
my $gene_color_sets = [
- [qw( blue blue blue blue ) => 'blue'],
- [qw( blue blue green blue ) => 'green'],
- [qw( blue blue blue green ) => 'green'],
- [qw( blue blue green green ) => 'green'],
- [qw( brown blue blue blue ) => 'brown'],
- [qw( brown brown green green ) => 'brown'],
- [qw( blue brown green blue ) => 'brown'],
+ [ qw( blue blue blue blue ) => 'blue' ],
+ [ qw( blue blue green blue ) => 'green' ],
+ [ qw( blue blue blue green ) => 'green' ],
+ [ qw( blue blue green green ) => 'green' ],
+ [ qw( brown blue blue blue ) => 'brown' ],
+ [ qw( brown brown green green ) => 'brown' ],
+ [ qw( blue brown green blue ) => 'brown' ],
];
foreach my $set (@$gene_color_sets) {
- my $expected_color = pop( @$set );
+ my $expected_color = pop(@$set);
+
my $person = Human->new(
- gender => 'f',
+ gender => 'f',
eye_color => $set,
);
+
is(
$person->eye_color(),
$expected_color,
- 'gene combination '.join(',',@$set).' produces '.$expected_color.' eye color',
+ 'gene combination '
+ . join( ',', @$set )
+ . ' produces '
+ . $expected_color
+ . ' eye color',
);
}
my $parent_sets = [
- [ [qw( blue blue blue blue )], [qw( blue blue blue blue )] => 'blue' ],
- [ [qw( blue blue blue blue )], [qw( brown brown green blue )] => 'brown' ],
- [ [qw( blue blue green green )], [qw( blue blue green green )] => 'green' ],
+ [
+ [qw( blue blue blue blue )],
+ [qw( blue blue blue blue )] => 'blue'
+ ],
+ [
+ [qw( blue blue blue blue )],
+ [qw( brown brown green blue )] => 'brown'
+ ],
+ [
+ [qw( blue blue green green )],
+ [qw( blue blue green green )] => 'green'
+ ],
];
foreach my $set (@$parent_sets) {
- my $expected_color = pop( @$set );
- my $mother = Human->new(
- gender => 'f',
+ my $expected_color = pop(@$set);
+
+ my $mother = Human->new(
+ gender => 'f',
eye_color => shift(@$set),
);
+
my $father = Human->new(
- gender => 'm',
+ gender => 'm',
eye_color => shift(@$set),
);
+
my $child = $mother + $father;
+
is(
$child->eye_color(),
$expected_color,
- 'mother '.$mother->eye_color().' + father '.$father->eye_color().' = child '.$expected_color,
+ 'mother '
+ . $mother->eye_color()
+ . ' + father '
+ . $father->eye_color()
+ . ' = child '
+ . $expected_color,
);
}
projects / gitmo/Moose.git / commitdiff