From 8a4a17246fd4b2192fd9dac5d2380c09c666b5ee Mon Sep 17 00:00:00 2001
From: Jesse Luehrs <doy@tozt.net>
Date: Mon, 15 Oct 2012 17:43:28 -0500
Subject: add maybe_doctype

---
 lib/MooseX/Meta/TypeConstraint/Doctype.pm | 15 ++++++-
 lib/MooseX/Validation/Doctypes.pm         | 46 ++++++++++++++++++-
 t/maybe-doctype.t                         | 75 +++++++++++++++++++++++++++++++
 3 files changed, 132 insertions(+), 4 deletions(-)
 create mode 100644 t/maybe-doctype.t

diff --git a/lib/MooseX/Meta/TypeConstraint/Doctype.pm b/lib/MooseX/Meta/TypeConstraint/Doctype.pm
index cc48312..18dfd7c 100644
--- a/lib/MooseX/Meta/TypeConstraint/Doctype.pm
+++ b/lib/MooseX/Meta/TypeConstraint/Doctype.pm
@@ -84,6 +84,11 @@ has doctype => (
     required => 1,
 );
 
+has maybe => (
+    is  => 'ro',
+    isa => 'Bool',
+);
+
 has '+parent' => (
     default => sub { find_type_constraint('Ref') },
 );
@@ -116,7 +121,10 @@ sub _validate_doctype {
 
     match_on_type $doctype => (
         'HashRef' => sub {
-            if (!find_type_constraint('HashRef')->check($data)) {
+            if ($self->maybe && !defined($data)) {
+                # ignore it
+            }
+            elsif (!find_type_constraint('HashRef')->check($data)) {
                 $errors = $self->_format_error($data, $prefix);
             }
             else {
@@ -146,7 +154,10 @@ sub _validate_doctype {
             }
         },
         'ArrayRef' => sub {
-            if (!find_type_constraint('ArrayRef')->check($data)) {
+            if ($self->maybe && !defined($data)) {
+                # ignore it
+            }
+            elsif (!find_type_constraint('ArrayRef')->check($data)) {
                 $errors = $self->_format_error($data, $prefix);
             }
             else {
diff --git a/lib/MooseX/Validation/Doctypes.pm b/lib/MooseX/Validation/Doctypes.pm
index ab19476..8de8696 100644
--- a/lib/MooseX/Validation/Doctypes.pm
+++ b/lib/MooseX/Validation/Doctypes.pm
@@ -6,9 +6,9 @@ use warnings;
 use MooseX::Meta::TypeConstraint::Doctype;
 
 use Sub::Exporter -setup => {
-    exports => ['doctype'],
+    exports => ['doctype', 'maybe_doctype'],
     groups => {
-        default => ['doctype'],
+        default => ['doctype', 'maybe_doctype'],
     },
 };
 
@@ -108,6 +108,48 @@ sub doctype {
     return $tc;
 }
 
+=func maybe_doctype $name, $doctype
+
+Identical to C<doctype>, except that undefined values are also allowed. This is
+useful when nesting doctypes, as in:
+
+  doctype 'Person' => {
+      id      => 'Str',
+      name    => maybe_doctype({
+          first => 'Str',
+          last  => 'Str',
+      }),
+      address => 'Str',
+  };
+
+This way, C<< { first => 'Bob', last => 'Smith' } >> is a valid name, and it's
+also valid to not provide a name, but an invalid name will still throw an
+error.
+
+=cut
+
+sub maybe_doctype {
+    my $name;
+    $name = shift if @_ > 1;
+
+    my ($doctype) = @_;
+
+    # XXX validate name
+
+    my $args = {
+        ($name ? (name => $name) : ()),
+        doctype            => $doctype,
+        package_defined_in => scalar(caller),
+        maybe              => 1,
+    };
+
+    my $tc = MooseX::Meta::TypeConstraint::Doctype->new($args);
+    Moose::Util::TypeConstraints::register_type_constraint($tc)
+        if $name;
+
+    return $tc;
+}
+
 =head1 BUGS
 
 No known bugs.
diff --git a/t/maybe-doctype.t b/t/maybe-doctype.t
new file mode 100644
index 0000000..5d15365
--- /dev/null
+++ b/t/maybe-doctype.t
@@ -0,0 +1,75 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Moose::Util::TypeConstraints 'find_type_constraint';
+
+use MooseX::Validation::Doctypes;
+
+doctype 'Person' => {
+    id    => 'Str',
+    name  => maybe_doctype({
+        first => 'Str',
+        last  => 'Str',
+    }),
+    title => 'Str',
+};
+
+{
+    my $person = find_type_constraint('Person');
+    isa_ok($person, 'Moose::Meta::TypeConstraint');
+    isa_ok($person, 'MooseX::Meta::TypeConstraint::Doctype');
+
+    is_deeply(
+        $person->doctype,
+        { id => 'Str', name => $person->doctype->{name}, title => 'Str' },
+        "got the right doctype"
+    );
+    is_deeply(
+        $person->doctype->{name}->doctype,
+        { first => 'Str', last => 'Str' },
+        "got the right doctype"
+    );
+
+    {
+        my $errors = $person->validate({
+            id    => '17382-QA',
+            name  => {
+                first => 'Bob',
+                last  => 'Smith',
+            },
+            title => 'CIO'
+        });
+        is($errors, undef, "no errors");
+    }
+
+    {
+        my $errors = $person->validate({
+            id    => '17382-QA',
+            name  => {
+                first => [],
+                last  => 'Smith',
+            },
+            title => 'CIO',
+        });
+        isa_ok($errors, 'MooseX::Validation::Doctypes::Errors');
+        is_deeply(
+            $errors->errors,
+            { name => { first => "invalid value [  ] for 'name.first'" } },
+            "got the right errors"
+        );
+        is($errors->extra_data, undef, "no errors");
+    }
+
+    {
+        my $errors = $person->validate({
+            id    => '17382-QA',
+            title => 'CIO'
+        });
+        is($errors, undef, "no errors");
+    }
+}
+
+
+done_testing;
-- 
cgit v1.2.3