=head1 SYNOPSIS
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) = @_;
-
+ 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) );
-
+ 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);
-
+ $gender = 'm' if ( rand() >= 0.5 );
+
return Human->new(
gender => $gender,
mother => $mother,
=head2 bey2
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
=head2 gey
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
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 );
+
+ 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
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');
+ 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';
}
the gene selection in human reproduction.
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();
-
+
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_2 => $two->$two_gey->color(),
);
}
-
+
sub _rand2 {
return 1 + int( rand(2) );
}
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 );
+ => 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,
+ gender => $gender,
eye_color => ( $one->eye_color() + $two->eye_color() ),
- mother => $mother,
- father => $father,
+ mother => $mother,
+ father => $father,
);
=head1 CONCLUSION
package BinaryTree;
use Moose;
-
- has 'node' => (is => 'rw', isa => 'Any');
-
+
+ has 'node' => ( is => 'rw', isa => 'Any' );
+
has 'parent' => (
is => 'rw',
- isa => 'BinaryTree',
+ isa => 'BinaryTree',
predicate => 'has_parent',
weak_ref => 1,
);
-
+
has 'left' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_left',
+ is => 'rw',
+ isa => 'BinaryTree',
+ predicate => 'has_left',
lazy => 1,
- default => sub { BinaryTree->new(parent => $_[0]) },
+ default => sub { BinaryTree->new( parent => $_[0] ) },
);
-
+
has 'right' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_right',
- lazy => 1,
- default => sub { BinaryTree->new(parent => $_[0]) },
+ is => 'rw',
+ isa => 'BinaryTree',
+ predicate => 'has_right',
+ lazy => 1,
+ default => sub { BinaryTree->new( parent => $_[0] ) },
);
-
+
before 'right', 'left' => sub {
- my ($self, $tree) = @_;
- $tree->parent($self) if defined $tree;
+ my ( $self, $tree ) = @_;
+ $tree->parent($self) if defined $tree;
};
=head1 DESCRIPTION
Now, let's start with the code. Our first attribute is the C<node>
slot, defined as such:
- has 'node' => (is => 'rw', isa => 'Any');
+ has 'node' => ( is => 'rw', isa => 'Any' );
If you recall from the previous recipes, this slot will have a read/write
accessor generated for it, and has a type constraint on it. The new item here is
has 'parent' => (
is => 'rw',
- isa => 'BinaryTree',
+ isa => 'BinaryTree',
predicate => 'has_parent',
weak_ref => 1,
);
save for different names, so I will just describe one here:
has 'left' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_left',
+ is => 'rw',
+ isa => 'BinaryTree',
+ predicate => 'has_left',
lazy => 1,
- default => sub { BinaryTree->new(parent => $_[0]) },
+ default => sub { BinaryTree->new( parent => $_[0] ) },
);
You already know what the C<is>, C<isa> and C<predicate> options do, but now we
(ARRAY ref, HASH ref, object instance, etc) you would need to
wrap it in a CODE reference, so this:
- has 'foo' => (is => 'rw', default => []);
+ has 'foo' => ( is => 'rw', default => [] );
is actually illegal in Moose. Instead, what you really want is this:
- has 'foo' => (is => 'rw', default => sub { [] });
+ has 'foo' => ( is => 'rw', default => sub { [] } );
This ensures that each instance of this class will get its own ARRAY ref in the
C<foo> slot.
where the slot will be stored. This can come in quite handy at times, as
illustrated above, with this code:
- default => sub { BinaryTree->new(parent => $_[0]) },
+ default => sub { BinaryTree->new( parent => $_[0] ) },
The default value being generated is a new C<BinaryTree> instance for the
C<left> (or C<right>) slot. Here we set up the correct relationship by passing
that would require us to implement all those features we got automatically (type
constraints, lazy initialization, and so on). Instead, we use method modifiers
again:
-
+
before 'right', 'left' => sub {
- my ($self, $tree) = @_;
- $tree->parent($self) if defined $tree;
+ my ( $self, $tree ) = @_;
+ $tree->parent($self) if defined $tree;
};
This is a C<before> modifier, just like we saw in the second recipe, but with
package Request;
use Moose;
use Moose::Util::TypeConstraints;
-
+
use HTTP::Headers ();
use Params::Coerce ();
use URI ();
-
+
subtype 'Header'
=> as 'Object'
=> where { $_->isa('HTTP::Headers') };
-
+
coerce 'Header'
=> from 'ArrayRef'
- => via { HTTP::Headers->new( @{ $_ } ) }
+ => via { HTTP::Headers->new( @{$_} ) }
=> from 'HashRef'
- => via { HTTP::Headers->new( %{ $_ } ) };
-
+ => via { HTTP::Headers->new( %{$_} ) };
+
subtype 'Uri'
=> as 'Object'
=> where { $_->isa('URI') };
-
+
coerce 'Uri'
=> from 'Object'
- => via { $_->isa('URI')
- ? $_
- : Params::Coerce::coerce( 'URI', $_ ) }
+ => via { $_->isa('URI')
+ ? $_
+ : Params::Coerce::coerce( 'URI', $_ ); }
=> from 'Str'
=> via { URI->new( $_, 'http' ) };
-
+
subtype 'Protocol'
- => as Str
+ => as 'Str'
=> where { /^HTTP\/[0-9]\.[0-9]$/ };
-
- has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
- has 'uri' => (is => 'rw', isa => 'Uri', coerce => 1);
- has 'method' => (is => 'rw', isa => 'Str');
- has 'protocol' => (is => 'rw', isa => 'Protocol');
+
+ has 'base' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+ has 'uri' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+ has 'method' => ( is => 'rw', isa => 'Str' );
+ has 'protocol' => ( is => 'rw', isa => 'Protocol' );
has 'headers' => (
is => 'rw',
isa => 'Header',
coerce => 1,
- default => sub { HTTP::Headers->new }
+ default => sub { HTTP::Headers->new }
);
=head1 DESCRIPTION
-This recipe introduces the idea of type coercions, and the C<coerce>
-keyword. Coercions can be attached to existing type constraints,
-and can be used to transform input of one type into input of another
-type. This can be an extremely powerful tool if used correctly, which
-is why it is off by default. If you want your accessor to attempt
-a coercion, you must specifically ask for it with the B<coerce> option.
+This recipe introduces the idea of type coercions, and the C<coerce>
+keyword. Coercions can be attached to existing type constraints, and
+can be used to transform input of one type into input of another
+type. This can be an extremely powerful tool if used correctly, which
+is why it is off by default. If you want your accessor to attempt a
+coercion, you must specifically ask for it with the B<coerce> option.
-Now, onto the coercions.
+Now, onto the coercions.
-First we need to create a subtype to attach our coercion to. Here we
-create a basic I<Header> subtype, which matches any instance of the
+First we need to create a subtype to attach our coercion to. Here we
+create a basic I<Header> subtype, which matches any instance of the
class B<HTTP::Headers>:
subtype 'Header'
The simplest thing from here would be create an accessor declaration
like this:
- has 'headers' => (
+ has 'headers' => (
is => 'rw',
isa => 'Header',
- default => sub { HTTP::Headers->new }
+ default => sub { HTTP::Headers->new }
);
-We would then have a self-validating accessor whose default value is
-an empty instance of B<HTTP::Headers>. This is nice, but it is not
+We would then have a self-validating accessor whose default value is
+an empty instance of B<HTTP::Headers>. This is nice, but it is not
ideal.
The constructor for B<HTTP::Headers> accepts a list of key-value pairs
-representing the HTTP header fields. In Perl, such a list could
-easily be stored in an ARRAY or HASH reference. We would like our
-class's interface to be able to accept this list of key-value pairs
-in place of the B<HTTP::Headers> instance, and just DWIM. This is where
+representing the HTTP header fields. In Perl, such a list could easily
+be stored in an ARRAY or HASH reference. We would like our class's
+interface to be able to accept this list of key-value pairs in place
+of the B<HTTP::Headers> instance, and just DWIM. This is where
coercion can help. First, let's declare our coercion:
coerce 'Header'
=> from 'ArrayRef'
- => via { HTTP::Headers->new( @{ $_ } ) }
+ => via { HTTP::Headers->new( @{$_} ) }
=> from 'HashRef'
- => via { HTTP::Headers->new( %{ $_ } ) };
+ => via { HTTP::Headers->new( %{$_} ) };
We first tell it that we are attaching the coercion to the 'Header'
-subtype. We then give it a set of C<from> clauses which map other
-subtypes to coercion routines (through the C<via> keyword). Fairly
-simple really; however, this alone does nothing. We have to tell
-our attribute declaration to actually use the coercion, like so:
+subtype. We then give it a set of C<from> clauses which map other
+subtypes to coercion routines (through the C<via> keyword). Fairly
+simple really; however, this alone does nothing. We have to tell our
+attribute declaration to actually use the coercion, like so:
- has 'headers' => (
+ has 'headers' => (
is => 'rw',
isa => 'Header',
coerce => 1,
- default => sub { HTTP::Headers->new }
+ default => sub { HTTP::Headers->new }
);
This will coerce any B<ArrayRef> or B<HashRef> which is passed into
the C<headers> accessor into an instance of B<HTTP::Headers>. So the
the following lines of code are all equivalent:
- $foo->headers(HTTP::Headers->new(bar => 1, baz => 2));
- $foo->headers([ 'bar', 1, 'baz', 2 ]);
- $foo->headers({ bar => 1, baz => 2 });
+ $foo->headers( HTTP::Headers->new( bar => 1, baz => 2 ) );
+ $foo->headers( [ 'bar', 1, 'baz', 2 ] );
+ $foo->headers( { bar => 1, baz => 2 } );
-As you can see, careful use of coercions can produce a very open
-interface for your class, while still retaining the "safety" of
-your type constraint checks.
+As you can see, careful use of coercions can produce a very open
+interface for your class, while still retaining the "safety" of your
+type constraint checks.
-Our next coercion takes advantage of the power of CPAN to handle
-the details of our coercion. In this particular case it uses the
+Our next coercion takes advantage of the power of CPAN to handle the
+details of our coercion. In this particular case it uses the
L<Params::Coerce> module, which fits in rather nicely with L<Moose>.
-Again, we create a simple subtype to represent instances of the
-B<URI> class:
+Again, we create a simple subtype to represent instances of the B<URI>
+class:
subtype 'Uri'
=> as 'Object'
coerce 'Uri'
=> from 'Object'
- => via { $_->isa('URI')
- ? $_
- : Params::Coerce::coerce( 'URI', $_ ) }
+ => via { $_->isa('URI')
+ ? $_
+ : Params::Coerce::coerce( 'URI', $_ ); }
=> from 'Str'
=> via { URI->new( $_, 'http' ) };
-The first C<from> clause we introduce is for the 'Object' subtype. An 'Object'
-is simply any C<bless>ed value. This means that if the coercion encounters
-another object, it should use this clause. Now we look at the C<via> block.
-First it checks to see if the object is a B<URI> instance. Since the coercion
-process occurs prior to any type constraint checking, it is entirely possible
-for this to happen, and if it does happen, we simply want to pass the instance
-on through. However, if it is not an instance of B<URI>, then we need to coerce
-it. This is where L<Params::Coerce> can do its magic, and we can just use its
-return value. Simple really, and much less work since we used a module from CPAN
-:)
-
-The second C<from> clause is attached to the 'Str' subtype, and
-illustrates how coercions can also be used to handle certain
-'default' behaviors. In this coercion, we simple take any string
-and pass it to the B<URI> constructor along with the default
-'http' scheme type.
-
-And of course, our coercions do nothing unless they are told to,
-like so:
-
- has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
- has 'uri' => (is => 'rw', isa => 'Uri', coerce => 1);
-
-As you can see, re-using the coercion allows us to enforce a
+The first C<from> clause we introduce is for the 'Object' subtype. An
+'Object' is simply any C<bless>ed value. This means that if the
+coercion encounters another object, it should use this clause. Now we
+look at the C<via> block. First it checks to see if the object is a
+B<URI> instance. Since the coercion process occurs prior to any type
+constraint checking, it is entirely possible for this to happen, and
+if it does happen, we simply want to pass the instance on
+through. However, if it is not an instance of B<URI>, then we need to
+coerce it. This is where L<Params::Coerce> can do its magic, and we
+can just use its return value. Simple really, and much less work since
+we used a module from CPAN :)
+
+The second C<from> clause is attached to the 'Str' subtype, and
+illustrates how coercions can also be used to handle certain 'default'
+behaviors. In this coercion, we simple take any string and pass it to
+the B<URI> constructor along with the default 'http' scheme type.
+
+And of course, our coercions do nothing unless they are told to, like
+so:
+
+ has 'base' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+ has 'uri' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+
+As you can see, re-using the coercion allows us to enforce a
consistent and very flexible API across multiple accessors.
=head1 CONCLUSION
-This recipe illustrated the power of coercions to build a more
-flexible and open API for your accessors, while still retaining
-all the safety that comes from using Moose's type constraints.
-Using coercions it becomes simple to manage (from a single
-location) a consistent API not only across multiple accessors,
-but across multiple classes as well.
+This recipe illustrated the power of coercions to build a more
+flexible and open API for your accessors, while still retaining all
+the safety that comes from using Moose's type constraints. Using
+coercions it becomes simple to manage (from a single location) a
+consistent API not only across multiple accessors, but across multiple
+classes as well.
-In the next recipe, we will introduce roles, a concept originally
-borrowed from Smalltalk, which made its way into Perl 6, and
-now into Moose.
+In the next recipe, we will introduce roles, a concept originally
+borrowed from Smalltalk, which made its way into Perl 6, and now into
+Moose.
=head1 AUTHOR
projects / gitmo/Moose.git / commitdiff