Version 0.20.

[gitmo/MooseX-Types-Structured.git] / lib / MooseX / Types / Structured.pm

diff --git a/lib/MooseX/Types/Structured.pm b/lib/MooseX/Types/Structured.pm
index d534f44..2303f17 100644 (file)
--- a/lib/MooseX/Types/Structured.pm
+++ b/lib/MooseX/Types/Structured.pm
@@ -4,13 +4,14 @@ use 5.008;
 
 use Moose::Util::TypeConstraints;
 use MooseX::Meta::TypeConstraint::Structured;
+use MooseX::Meta::TypeConstraint::Structured::Optional;
 use MooseX::Types::Structured::OverflowHandler;
-use MooseX::Types -declare => [qw(Dict Tuple Optional)];
-use Sub::Exporter -setup => { exports => [ qw(Dict Tuple Optional slurpy) ] };
+use MooseX::Types -declare => [qw(Dict Map Tuple Optional)];
+use Sub::Exporter -setup => [ qw(Dict Map Tuple Optional slurpy) ];
 use Devel::PartialDump;
 use Scalar::Util qw(blessed);
 
-our $VERSION = '0.19';
+our $VERSION = '0.20';
 our $AUTHORITY = 'cpan:JJNAPIORK';
 
 =head1 NAME
@@ -500,6 +501,17 @@ hashref.  For example:
 The keys in %constraints follow the same rules as @constraints in the above
 section.
 
+=head2 Map[ $key_constraint, $value_constraint ]
+
+This defines a HashRef based constraint in which both the keys and values are
+required to meet certain constraints.  For example, to map hostnames to IP
+addresses, you might say:
+
+  Map[ HostName, IPAddress ]
+
+The type constraint would only be met if every key was a valid HostName and
+every value was a valid IPAddress.
+
 =head2 Optional[$constraint]
 
 This is primarily a helper constraint for Dict and Tuple type constraints.  What
@@ -689,6 +701,32 @@ clean and declarative way.
 
 =cut
 
+my $Optional = MooseX::Meta::TypeConstraint::Structured::Optional->new(
+    name => 'MooseX::Types::Structured::Optional',
+    package_defined_in => __PACKAGE__,
+    parent => find_type_constraint('Item'),
+    constraint => sub { 1 },
+    constraint_generator => sub {
+        my ($type_parameter, @args) = @_;
+        my $check = $type_parameter->_compiled_type_constraint();
+        return sub {
+            my (@args) = @_;
+            ## Does the arg exist?  Something exists if it's a 'real' value
+            ## or if it is set to undef.
+            if(exists($args[0])) {
+                ## If it exists, we need to validate it
+                $check->($args[0]);
+            } else {
+                ## But it's is okay if the value doesn't exists
+                return 1;
+            }
+        }
+    }
+);
+
+Moose::Util::TypeConstraints::register_type_constraint($Optional);
+Moose::Util::TypeConstraints::add_parameterizable_type($Optional);
+
 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
        MooseX::Meta::TypeConstraint::Structured->new(
                name => "MooseX::Types::Structured::Tuple" ,
@@ -718,7 +756,7 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
                                        }
                                } else {
                     ## Test if the TC supports null values
-                                       unless($type_constraint->check()) {
+                    unless ($type_constraint->is_subtype_of($Optional)) {
                         $_[2]->{message} = $type_constraint->get_message('NULL')
                          if ref $_[2];
                                                return;
@@ -777,7 +815,7 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
                                        }
                                } else {
                     ## Test to see if the TC supports null values
-                                       unless($type_constraint->check()) {
+                    unless ($type_constraint->is_subtype_of($Optional)) {
                         $_[2]->{message} = $type_constraint->get_message('NULL')
                          if ref $_[2];
                                                return;
@@ -805,33 +843,45 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
        )
 );
 
-OPTIONAL: {
-    my $Optional = Moose::Meta::TypeConstraint::Parameterizable->new(
-        name => 'MooseX::Types::Structured::Optional',
-        package_defined_in => __PACKAGE__,
-        parent => find_type_constraint('Item'),
-        constraint => sub { 1 },
-        constraint_generator => sub {
-            my ($type_parameter, @args) = @_;
-            my $check = $type_parameter->_compiled_type_constraint();
-            return sub {
-                my (@args) = @_;
-                ## Does the arg exist?  Something exists if it's a 'real' value
-                ## or if it is set to undef.
-                if(exists($args[0])) {
-                    ## If it exists, we need to validate it
-                    $check->($args[0]);
-                } else {
-                    ## But it's is okay if the value doesn't exists
-                    return 1;
-                }
-            }
+Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
+  MooseX::Meta::TypeConstraint::Structured->new(
+    name => "MooseX::Types::Structured::Map",
+    parent => find_type_constraint('HashRef'),
+    constraint_generator=> sub {
+      ## Get the constraints and values to check
+      my ($type_constraints, $values) = @_;
+      my @constraints = defined $type_constraints ? @$type_constraints : ();
+
+      Carp::confess( "too many args for Map type" ) if @constraints > 2;
+
+      my ($key_type, $value_type) = @constraints == 2 ? @constraints
+                                  : @constraints == 1 ? (undef, @constraints)
+                                  :                     ();
+
+      my %values = defined $values ? %$values: ();
+      ## Perform the checking
+      if ($value_type) {
+        for my $value (values %$values) {
+          unless ($value_type->check($value)) {
+            $_[2]->{message} = $value_type->get_message($value) if ref $_[2];
+            return;
+          }
         }
-    );
+      }
+
+      if ($key_type) {
+        for my $key (keys %$values) {
+          unless ($key_type->check($key)) {
+            $_[2]->{message} = $key_type->get_message($key) if ref $_[2];
+            return;
+          }
+        }
+      }
 
-    Moose::Util::TypeConstraints::register_type_constraint($Optional);
-    Moose::Util::TypeConstraints::add_parameterizable_type($Optional);
-}
+      return 1;
+    },
+  )
+);
 
 sub slurpy ($) {
        my ($tc) = @_;