From: Ricardo SIGNES <rjbs@cpan.org>
Date: Wed, 21 Jan 2009 22:23:09 +0000 (+0000)
Subject: maybe_type
X-Git-Tag: 0.65~15
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1b2c9bda92c60f6b05de1d1805549faaceaebced;p=gitmo%2FMoose.git

maybe_type
---

diff --git a/Changes b/Changes
index 4c20c78..d5fb9a8 100644
--- a/Changes
+++ b/Changes
@@ -15,6 +15,8 @@ Revision history for Perl extension Moose
         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)
diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index d4b97d6..aa9da35 100644
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -47,7 +47,8 @@ use Moose::Util::TypeConstraints::OptimizedConstraints;
 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 role_type ($;$) {
     );
 }
 
+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 @@ L<Moose::Meta::TypeConstraint::Class>.
 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.
diff --git a/t/040_type_constraints/021_maybe_type_constraint.t b/t/040_type_constraints/021_maybe_type_constraint.t
index e97986c..a8db74c 100644
--- a/t/040_type_constraints/021_maybe_type_constraint.t
+++ b/t/040_type_constraints/021_maybe_type_constraint.t
@@ -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('Hello World'), '... checked type correctly (fail)');
 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 @@ ok !$Maybe_Int->check("a")
 
 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")';