[Moose-commits] r7348 - in Moose/trunk: . lib/Moose/Util t/040_type_constraints

[rjbs at code2.0beta.co.uk]

Author: rjbs
Date: 2009-01-21 14:23:09 -0800 (Wed, 21 Jan 2009)
New Revision: 7348

Modified:
   Moose/trunk/Changes
   Moose/trunk/lib/Moose/Util/TypeConstraints.pm
   Moose/trunk/t/040_type_constraints/021_maybe_type_constraint.t
Log:
maybe_type

Modified: Moose/trunk/Changes
===================================================================
--- Moose/trunk/Changes	2009-01-19 17:38:28 UTC (rev 7347)
+++ Moose/trunk/Changes	2009-01-21 22:23:09 UTC (rev 7348)
@@ -15,6 +15,8 @@
         validate filesystem paths in a very ad-hoc and
         not-quite-correct way. (Dave Rolsky)
 
+    * added maybe_type to exports of Moose::Util::TypeConstraints (rjbs)
+
 0.64 Wed, December 31, 2008
     * Moose::Meta::Method::Accessor
       - Always inline predicate and clearer methods (Sartak)

Modified: Moose/trunk/lib/Moose/Util/TypeConstraints.pm
===================================================================
--- Moose/trunk/lib/Moose/Util/TypeConstraints.pm	2009-01-19 17:38:28 UTC (rev 7347)
+++ Moose/trunk/lib/Moose/Util/TypeConstraints.pm	2009-01-21 22:23:09 UTC (rev 7348)
@@ -47,7 +47,8 @@
 Moose::Exporter->setup_import_methods(
     as_is => [
         qw(
-            type subtype class_type role_type as where message optimize_as
+            type subtype class_type role_type maybe_type
+            as where message optimize_as
             coerce from via
             enum
             find_type_constraint
@@ -301,6 +302,19 @@
     );
 }
 
+sub maybe_type {
+    my ($type_parameter) = @_;
+
+    Moose::Meta::TypeConstraint->new(
+        parent               => find_type_constraint('Item'),
+        constraint           => sub {
+            my $check = $type_parameter->_compiled_type_constraint;
+            return 1 if not(defined($_)) || $check->($_);
+            return;
+        }
+    )
+}
+
 sub coerce {
     my ($type_name, @coercion_map) = @_;
     _install_type_coercions($type_name, \@coercion_map);
@@ -845,6 +859,11 @@
 Creates a type constraint with the name C<$role> and the metaclass
 L<Moose::Meta::TypeConstraint::Role>.
 
+=item B<maybe_type ($type)>
+
+Creates a type constraint for either C<undef> or something of the
+given type.
+
 =item B<enum ($name, @values)>
 
 This will create a basic subtype for a given set of strings.

Modified: Moose/trunk/t/040_type_constraints/021_maybe_type_constraint.t
===================================================================
--- Moose/trunk/t/040_type_constraints/021_maybe_type_constraint.t	2009-01-19 17:38:28 UTC (rev 7347)
+++ Moose/trunk/t/040_type_constraints/021_maybe_type_constraint.t	2009-01-21 22:23:09 UTC (rev 7348)
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 31;
+use Test::More tests => 36;
 use Test::Exception;
 
 use Moose::Util::TypeConstraints;
@@ -26,26 +26,52 @@
 ok(!$type->check([]), '... checked type correctly (fail)');
 
 {
+    package Bar;
+    use Moose;
+
     package Foo;
     use Moose;
+    use Moose::Util::TypeConstraints;
     
-    has 'bar' => (is => 'rw', isa => 'Maybe[ArrayRef]', required => 1);    
+    has 'arr' => (is => 'rw', isa => 'Maybe[ArrayRef]', required => 1);    
+    has 'bar' => (is => 'rw', isa => class_type('Bar'));
+    has 'maybe_bar' => (is => 'rw', isa => maybe_type(class_type('Bar')));
 }
 
 lives_ok {
-    Foo->new(bar => []);
+    Foo->new(arr => [], bar => Bar->new);
+} '... Bar->new isa Bar';
+
+dies_ok {
+    Foo->new(arr => [], bar => undef);
+} '... undef isnta Bar';
+
+lives_ok {
+    Foo->new(arr => [], maybe_bar => Bar->new);
+} '... Bar->new isa maybe(Bar)';
+
+lives_ok {
+    Foo->new(arr => [], maybe_bar => undef);
+} '... undef isa maybe(Bar)';
+
+dies_ok {
+    Foo->new(arr => [], maybe_bar => 1);
+} '... 1 isnta maybe(Bar)';
+
+lives_ok {
+    Foo->new(arr => []);
 } '... it worked!';
 
 lives_ok {
-    Foo->new(bar => undef);
+    Foo->new(arr => undef);
 } '... it worked!';
 
 dies_ok {
-    Foo->new(bar => 100);
+    Foo->new(arr => 100);
 } '... failed the type check';
 
 dies_ok {
-    Foo->new(bar => 'hello world');
+    Foo->new(arr => 'hello world');
 } '... failed the type check';
 
 
@@ -104,4 +130,4 @@
 
 throws_ok sub { $obj->Maybe_Int("a") }, 
  qr/Attribute \(Maybe_Int\) does not pass the type constraint/
- => 'failed assigned ("a")';
\ No newline at end of file
+ => 'failed assigned ("a")';