From: Dave Rolsky Date: Tue, 10 Feb 2009 19:43:35 +0000 (+0000) Subject: Revised recipe 10 and updated the test code to match. X-Git-Tag: 0.69~27 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=055dbe8cc7790bc2930fddeb37642b68b767422b;p=gitmo%2FMoose.git Revised recipe 10 and updated the test code to match. --- diff --git a/lib/Moose/Cookbook/Basics/Recipe10.pod b/lib/Moose/Cookbook/Basics/Recipe10.pod index 343b673..7031140 100644 --- a/lib/Moose/Cookbook/Basics/Recipe10.pod +++ b/lib/Moose/Cookbook/Basics/Recipe10.pod @@ -46,137 +46,103 @@ Moose::Cookbook::Basics::Recipe10 - Operator overloading, subtypes, and coercion 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 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 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 a Moose-specific feature. It's a general OO +concept that is implemented in Perl with the C +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 to see some good, basic, examples. - -=head2 Subtypes - -Moose comes with 21 default type constraints, as documented in -L. C, C, and C 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. - -=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. +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 and I. 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 and I. 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 -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 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 gene is nearly identical to I, except that it -has a green or blue variety. +This is nearly identical to the C class, except +that the I gene allows for different colors. =head1 EYE COLOR -Rather than throwing the 4 gene object (2 x I, 2 x I) straight -on to the C class, let's create an intermediate class that -abstracts the logic behind eye color. This way the C 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 class, but this is a bit messy. Instead, we'll abstract the +genes into a container class, C. Then a C can +have a single C 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 -brown gene is dominant to both blue and green. The I green gene is -recessive to the brown I gene and dominant to the blues. Finally, -the I and I 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. + +We also need a method to calculate the actual eye color that results +from a set of genes. The I brown gene is dominant over both blue +and green. The I green gene dominant over blue. sub color { my ($self) = @_; @@ -192,21 +158,14 @@ the I and I blue genes are recessive to both brown and green. return 'blue'; } -To top it off, if I want to access C, 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. 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 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 characteristics to -create a new C 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 objects and get a new one with a +new (genetically correct) eye color. use overload '+' => \&_overload_add, fallback => 1; @@ -231,40 +190,32 @@ the gene selection in human reproduction. 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 objects. These are the +left and right side operands for the C<+> operator. This method +returns a new C object. -=head1 HUMAN EVOLUTION +=head1 ADDING EYE COLOR TO Cs -Our original human class in the L requires very little -change to support the new C characteristic. All we -need to do is define a new subtype called C, a new -attribute called C, and just for the sake of simple code -we'll coerce an arrayref of colors in to an C object. +Our original C class requires just a few changes to incorporate +our new C 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 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 class to +account for eye color: return Human->new( gender => $gender, @@ -275,12 +226,13 @@ the mother and father's eye colors. =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 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. =head1 NEXT STEPS @@ -301,10 +253,12 @@ Has this been a real project we'd probably want to: =back -=head1 AUTHOR +=head1 AUTHORS Aran Clary Deltac +Dave Rolsky Eautarch@urth.orgE + =head1 LICENSE This work is licensed under a Creative Commons Attribution 3.0 Unported License. diff --git a/t/000_recipes/basics/010_genes.t b/t/000_recipes/basics/010_genes.t index b638438..c9f34eb 100644 --- a/t/000_recipes/basics/010_genes.t +++ b/t/000_recipes/basics/010_genes.t @@ -3,105 +3,124 @@ 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(); @@ -118,81 +137,78 @@ use warnings; } 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, ); }