[Moose-commits] r7654 - in Moose/trunk: . lib/Moose/Cookbook/Basics
lib/Moose/Util lib/Moose/Util/TypeConstraints
t/000_recipes/basics t/040_type_constraints
stevan at code2.0beta.co.uk
stevan at code2.0beta.co.uk
Fri Feb 13 19:01:11 GMT 2009
Author: stevan
Date: 2009-02-13 11:01:11 -0800 (Fri, 13 Feb 2009)
New Revision: 7654
Modified:
Moose/trunk/Changes
Moose/trunk/lib/Moose/Cookbook/Basics/Recipe3.pod
Moose/trunk/lib/Moose/Util/TypeConstraints.pm
Moose/trunk/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm
Moose/trunk/t/000_recipes/basics/003_binary_tree.t
Moose/trunk/t/040_type_constraints/003_util_std_type_constraints.t
Log:
adding more tests to the binary tree recipe, and adding the RoleName type constraint
Modified: Moose/trunk/Changes
===================================================================
--- Moose/trunk/Changes 2009-02-13 16:12:30 UTC (rev 7653)
+++ Moose/trunk/Changes 2009-02-13 19:01:11 UTC (rev 7654)
@@ -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
Modified: Moose/trunk/lib/Moose/Cookbook/Basics/Recipe3.pod
===================================================================
--- Moose/trunk/lib/Moose/Cookbook/Basics/Recipe3.pod 2009-02-13 16:12:30 UTC (rev 7653)
+++ Moose/trunk/lib/Moose/Cookbook/Basics/Recipe3.pod 2009-02-13 19:01:11 UTC (rev 7654)
@@ -37,7 +37,11 @@
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 @@
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,
Modified: Moose/trunk/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm
===================================================================
--- Moose/trunk/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm 2009-02-13 16:12:30 UTC (rev 7653)
+++ Moose/trunk/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm 2009-02-13 19:01:11 UTC (rev 7654)
@@ -60,6 +60,11 @@
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
Modified: Moose/trunk/lib/Moose/Util/TypeConstraints.pm
===================================================================
--- Moose/trunk/lib/Moose/Util/TypeConstraints.pm 2009-02-13 16:12:30 UTC (rev 7653)
+++ Moose/trunk/lib/Moose/Util/TypeConstraints.pm 2009-02-13 19:01:11 UTC (rev 7654)
@@ -575,14 +575,18 @@
=> 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 ...
Modified: Moose/trunk/t/000_recipes/basics/003_binary_tree.t
===================================================================
--- Moose/trunk/t/000_recipes/basics/003_binary_tree.t 2009-02-13 16:12:30 UTC (rev 7653)
+++ Moose/trunk/t/000_recipes/basics/003_binary_tree.t 2009-02-13 19:01:11 UTC (rev 7654)
@@ -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 @@
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 @@
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 @@
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';
+
Modified: Moose/trunk/t/040_type_constraints/003_util_std_type_constraints.t
===================================================================
--- Moose/trunk/t/040_type_constraints/003_util_std_type_constraints.t 2009-02-13 16:12:30 UTC (rev 7653)
+++ Moose/trunk/t/040_type_constraints/003_util_std_type_constraints.t 2009-02-13 19:01:11 UTC (rev 7654)
@@ -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('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";
More information about the Moose-commits
mailing list