From: Stevan Little Date: Fri, 13 Feb 2009 19:01:11 +0000 (+0000) Subject: adding more tests to the binary tree recipe, and adding the RoleName type constraint X-Git-Tag: 0.70~27 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f0cac16f5d38fad900b47293d050d37f791f580d;p=gitmo%2FMoose.git adding more tests to the binary tree recipe, and adding the RoleName type constraint --- diff --git a/Changes b/Changes index 11c00e4..2bbe071 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,15 @@ Revision history for Perl extension Moose +0.70 + * Moose::Util::TypeConstraints + - added the RoleName type + - added tests for this + + * Moose::Cookbook::Basics::Recipe3 + - updating the before qw[left right] to be a little more + defensive about what it accepts + - added more tests to t/000_recipies/basics/003_binary_tree.t + 0.69 Thu, February 12, 2009 * Moose - Make some keyword errors use throw_error instead of croak diff --git a/lib/Moose/Cookbook/Basics/Recipe3.pod b/lib/Moose/Cookbook/Basics/Recipe3.pod index f4063c2..68edfd4 100644 --- a/lib/Moose/Cookbook/Basics/Recipe3.pod +++ b/lib/Moose/Cookbook/Basics/Recipe3.pod @@ -37,7 +37,11 @@ Moose::Cookbook::Basics::Recipe3 - A lazy B example before 'right', 'left' => sub { my ( $self, $tree ) = @_; - $tree->parent($self) if defined $tree; + if (defined $tree) { + confess "You cannot insert a tree which already has a parent" + if $tree->has_parent; + $tree->parent($self); + } }; =head1 DESCRIPTION @@ -151,7 +155,11 @@ Instead, we use method modifiers: before 'right', 'left' => sub { my ( $self, $tree ) = @_; - $tree->parent($self) if defined $tree; + if (defined $tree) { + confess "You cannot insert a tree which already has a parent" + if $tree->has_parent; + $tree->parent($self); + } }; This is a C modifier, just like we saw in the second recipe, diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index c9b4e43..6a3d183 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -575,14 +575,18 @@ subtype 'Role' => where { $_->can('does') } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role; -my $_class_name_checker = sub { -}; +my $_class_name_checker = sub {}; subtype 'ClassName' => as 'Str' => where { Class::MOP::is_class_loaded($_) } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName; +subtype 'RoleName' + => as 'ClassName' + => where { (($_->can('meta') || return)->($_) || return)->isa('Moose::Meta::Role') } + => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName; ; + ## -------------------------------------------------------- # parameterizable types ... diff --git a/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm b/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm index 7540115..38022ec 100644 --- a/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm +++ b/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm @@ -60,6 +60,11 @@ sub ClassName { return 0; } +sub RoleName { + ClassName($_[0]) + && (($_[0]->can('meta') || return)->($_[0]) || return)->isa('Moose::Meta::Role') +} + # NOTE: # we have XS versions too, ... # 04:09 <@konobi> nothingmuch: konobi.co.uk/code/utilsxs.tar.gz diff --git a/t/000_recipes/basics/003_binary_tree.t b/t/000_recipes/basics/003_binary_tree.t index ac03763..d271b62 100644 --- a/t/000_recipes/basics/003_binary_tree.t +++ b/t/000_recipes/basics/003_binary_tree.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 33; +use Test::More tests => 41; use Test::Exception; use Scalar::Util 'isweak'; @@ -39,7 +39,11 @@ use Scalar::Util 'isweak'; before 'right', 'left' => sub { my ( $self, $tree ) = @_; - $tree->parent($self) if defined $tree; + if (defined $tree) { + confess "You cannot insert a tree which already has a parent" + if $tree->has_parent; + $tree->parent($self); + } }; __PACKAGE__->meta->make_immutable( debug => 0 ); @@ -104,6 +108,8 @@ 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'); @@ -115,3 +121,26 @@ 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'); + +lives_ok { + $left->right($left_right) +} '... 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 + +dies_ok { + $left_right->right($left_left) +} '... cant assign a node which already has a parent'; + diff --git a/t/040_type_constraints/003_util_std_type_constraints.t b/t/040_type_constraints/003_util_std_type_constraints.t index 83dbaef..e9c2d44 100644 --- a/t/040_type_constraints/003_util_std_type_constraints.t +++ b/t/040_type_constraints/003_util_std_type_constraints.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 273; +use Test::More tests => 291; use Test::Exception; use Scalar::Util (); @@ -328,4 +328,30 @@ ok(defined ClassName('UNIVERSAL'), '... ClassName accepts anything which is ok(defined ClassName('Quux::Wibble'), '... ClassName accepts anything which is a ClassName'); ok(defined ClassName('Moose::Meta::TypeConstraint'), '... ClassName accepts anything which is a ClassName'); +ok(!defined RoleName(0), '... RoleName rejects anything which is not a RoleName'); +ok(!defined RoleName(100), '... RoleName rejects anything which is not a RoleName'); +ok(!defined RoleName(''), '... RoleName rejects anything which is not a RoleName'); +ok(!defined RoleName('Baz'), '... RoleName rejects anything which is not a RoleName'); + +{ + package Quux::Wibble::Role; # this makes Quux symbol table exist + use Moose::Role; + sub foo {} +} + +ok(!defined RoleName('Quux'), '... RoleName rejects anything which is not a RoleName'); +ok(!defined RoleName([]), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName({}), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName(sub {}), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName($SCALAR_REF), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName($fh), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName($GLOB_REF), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName(qr/../), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName(bless {}, 'Foo'), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName(undef), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName('UNIVERSAL'), '... RoleName accepts anything which is a RoleName'); +ok(!defined RoleName('Quux::Wibble'), '... RoleName accepts anything which is a RoleName'); +ok(!defined RoleName('Moose::Meta::TypeConstraint'), '... RoleName accepts anything which is a RoleName'); +ok(defined RoleName('Quux::Wibble::Role'), '... RoleName accepts anything which is a RoleName'); + close($fh) || die "Could not close the filehandle $0 for test";