predicate => 'has_left',
lazy => 1,
default => sub { BinaryTree->new( parent => $_[0] ) },
+ trigger => \&_set_parent_for_child
);
has 'right' => (
predicate => 'has_right',
lazy => 1,
default => sub { BinaryTree->new( parent => $_[0] ) },
+ trigger => \&_set_parent_for_child
);
- before 'right', 'left' => sub {
- my ( $self, $tree ) = @_;
- $tree->parent($self) if defined $tree;
- };
+ sub _set_parent_for_child {
+ my ( $self, $child ) = @_;
+
+ confess "You cannot insert a tree which already has a parent"
+ if $child->has_parent;
+
+ $child->parent($self);
+ }
=head1 DESCRIPTION
This recipe shows how various advanced attribute features can be used
-to create complex and powerful behaviors.
+to create complex and powerful behaviors. In particular, we introduce
+a number of new attribute options, including C<predicate>, C<lazy>,
+and C<trigger>.
The example class is a classic binary tree. Each node in the tree is
itself an instance of C<BinaryTree>. It has a C<node>, which holds
has 'node' => ( is => 'rw', isa => 'Any' );
Moose generates a read-write accessor for this attribute. The type
-constraint is C<Any>, which means literally means it can contain
-anything.
+constraint is C<Any>, which literally means it can contain anything.
We could have left out the C<isa> option, but in this case, we are
-including ir for the benefit of other programmers, not the computer.
+including it for the benefit of other programmers, not the computer.
Next, let's move on to the C<parent> attribute:
predicate => 'has_left',
lazy => 1,
default => sub { BinaryTree->new( parent => $_[0] ) },
+ trigger => \&_set_parent_for_child
);
-There are two new options here, C<lazy> and C<default>. These two
-options are linked, and in fact you cannot have a C<lazy> attribute
-unless it has a C<default> (or a C<builder>, but we'll cover that
-later). If you try to make an attribute lazy without a default, class
-creation will fail with an exception. (2)
+There are three new options here, C<lazy>, C<default>, and
+C<trigger>. The C<lazy> and C<default> options options are linked. In
+fact, you cannot have a C<lazy> attribute unless it has a C<default>
+(or a C<builder>, but we'll cover that later). If you try to make an
+attribute lazy without a default, class creation will fail with an
+exception. (2)
In the second recipe the B<BankAccount>'s C<balance> attribute had a
default value of C<0>. Given a non-reference, Perl copies the
I<value>. However, given a reference, it does not do a deep clone,
-instead simply copying the reference. If you just specified a simply
+instead simply copying the reference. If you just specified a simple
reference for a default, Perl would create it once and it would be
shared by all objects with that attribute.
In fact, using a non-subroutine reference as a default is illegal in Moose.
+ # will fail
has 'foo' => ( is => 'rw', default => [] );
This will blow up, so don't do it.
In our case, we're making a new C<BinaryTree> object in our default,
with the current tree as the parent.
-Normally, when an object is instantiated, any defaults are evaluted
+Normally, when an object is instantiated, any defaults are evaluated
immediately. With our C<BinaryTree> class, this would be a big
problem! We'd create the first object, which would immediately try to
populate its C<left> and C<right> attributes, which would create a new
C<left> or C<right> attribute's tree.
We could write our own accessors, but then why use Moose at all?
-Instead, we use method modifiers:
-
- before 'right', 'left' => sub {
- 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 two slight differences. First, we are applying the modifier
-to more than one method at a time, because both C<left> and C<right>
-attributes need the same behavior. The other difference is that we are
-not wrapping an inherited method, but rather a method from our own
-local class. Wrapping local methods is no different, the only
-requirement is that the wrappee must exist before the wrapper is
-defined (after all, you cannot wrap something which doesn't exist,
-right?).
+Instead, we use a C<trigger>. A C<trigger> accepts a subroutine
+reference, which will be called as a method whenever the attribute is
+set. This can happen both during object construction or later by
+passing a new object to the attribute's accessor method. However, it
+is not called when a value is provided by a C<default> or C<builder>.
+
+ sub _set_parent_for_child {
+ my ( $self, $child ) = @_;
+
+ confess "You cannot insert a tree which already has a parent"
+ if $child->has_parent;
+
+ $child->parent($self);
+ }
+
+This trigger does two things. First, it ensures that the new child
+node does not already have a parent. This is done for the sake of
+simplifying the example. If we wanted to be more clever, we would
+remove the child from its old parent tree and add it to the new one.
+
+If the child has no parent, we will add it to the current tree, and we
+ensure that is has the correct value for its C<parent> attribute.
As with all the other recipes, B<BinaryTree> can be used just like any
other Perl 5 class. A more detailed example of its usage can be found
-in F<t/000_recipes/003_recipe.t>.
+in F<t/000_recipes/moose_cookbook_basics_recipe3.t>.
=head1 CONCLUSION
like, as we showed in the second recipe.
Also, you can use C<builder> instead of C<default>. See
-L<Moose::Cookbook::Basics::Recipe9> for details.
+L<Moose::Cookbook::Basics::Recipe8> for details.
=back
-=head1 AUTHOR
+=head1 AUTHORS
Stevan Little E<lt>stevan@iinteractive.comE<gt>
+Dave Rolsky E<lt>autarch@urth.orgE<gt>
+
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2009 by Infinity Interactive, Inc.
+Copyright 2006-2010 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+use Scalar::Util 'isweak';
+
+my $root = BinaryTree->new(node => 'root');
+isa_ok($root, 'BinaryTree');
+
+is($root->node, 'root', '... got the right node value');
+
+ok(!$root->has_left, '... no left node yet');
+ok(!$root->has_right, '... no right node yet');
+
+ok(!$root->has_parent, '... no parent for root node');
+
+# make a left node
+
+my $left = $root->left;
+isa_ok($left, 'BinaryTree');
+
+is($root->left, $left, '... got the same node (and it is $left)');
+ok($root->has_left, '... we have a left node now');
+
+ok($left->has_parent, '... lefts has a parent');
+is($left->parent, $root, '... lefts parent is the root');
+
+ok(isweak($left->{parent}), '... parent is a weakened ref');
+
+ok(!$left->has_left, '... $left no left node yet');
+ok(!$left->has_right, '... $left no right node yet');
+
+is($left->node, undef, '... left has got no node value');
+
+is(
+ exception {
+ $left->node('left');
+ },
+ undef,
+ '... assign to lefts node'
+);
+
+is($left->node, 'left', '... left now has a node value');
+
+# make a right node
+
+ok(!$root->has_right, '... still no right node yet');
+
+is($root->right->node, undef, '... right has got no node value');
+
+ok($root->has_right, '... now we have a right node');
+
+my $right = $root->right;
+isa_ok($right, 'BinaryTree');
+
+is(
+ exception {
+ $right->node('right');
+ },
+ undef,
+ '... assign to rights node'
+);
+
+is($right->node, 'right', '... left now has a node value');
+
+is($root->right, $right, '... got the same node (and it is $right)');
+ok($root->has_right, '... we have a right node now');
+
+ok($right->has_parent, '... rights has a parent');
+is($right->parent, $root, '... rights parent is the root');
+
+ok(isweak($right->{parent}), '... parent is a weakened ref');
+
+# make a left node of the left node
+
+my $left_left = $left->left;
+isa_ok($left_left, 'BinaryTree');
+
+ok($left_left->has_parent, '... left does have a parent');
+
+is($left_left->parent, $left, '... got a parent node (and it is $left)');
+ok($left->has_left, '... we have a left node now');
+is($left->left, $left_left, '... got a left node (and it is $left_left)');
+
+ok(isweak($left_left->{parent}), '... parent is a weakened ref');
+
+# make a right node of the left node
+
+my $left_right = BinaryTree->new;
+isa_ok($left_right, 'BinaryTree');
+
+is(
+ exception {
+ $left->right($left_right);
+ },
+ undef,
+ '... assign to rights node'
+);
+
+ok($left_right->has_parent, '... left does have a parent');
+
+is($left_right->parent, $left, '... got a parent node (and it is $left)');
+ok($left->has_right, '... we have a left node now');
+is($left->right, $left_right, '... got a left node (and it is $left_left)');
+
+ok(isweak($left_right->{parent}), '... parent is a weakened ref');
+
+# and check the error
+
+isnt(
+ exception {
+ $left_right->right($left_left);
+ },
+ undef,
+ '... cannot assign a node which already has a parent'
+);
+
+=end testing
+
=cut
projects / gitmo/Moose.git / blobdiff