adding more tests to the binary tree recipe, and adding the RoleName type constraint

diff --git a/Changes b/Changes
index 11c00e4..2bbe071 100644 (file)
--- 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 (file)
--- 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<BinaryTree> 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<before> 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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";