[Moose-commits] r7822 - in MooseX-Types-Structured/trunk: lib/MooseX/Types t

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

Author: jnapiorkowski
Date: 2009-03-05 08:44:48 -0800 (Thu, 05 Mar 2009)
New Revision: 7822

Added:
   MooseX-Types-Structured/trunk/t/11-overflow.t
Modified:
   MooseX-Types-Structured/trunk/lib/MooseX/Types/Structured.pm
Log:
first go at supporting callbacks in the type parameter list, added test for it

Modified: MooseX-Types-Structured/trunk/lib/MooseX/Types/Structured.pm
===================================================================
--- MooseX-Types-Structured/trunk/lib/MooseX/Types/Structured.pm	2009-03-04 23:49:51 UTC (rev 7821)
+++ MooseX-Types-Structured/trunk/lib/MooseX/Types/Structured.pm	2009-03-05 16:44:48 UTC (rev 7822)
@@ -572,7 +572,13 @@
 			## Get the constraints and values to check
             my ($type_constraints, $values) = @_;
 			my @type_constraints = defined $type_constraints ?
-             @$type_constraints : ();            
+             @$type_constraints : ();
+            
+            my $overflow_handler;
+            if(ref $type_constraints[-1] eq 'CODE') {
+                $overflow_handler = pop @type_constraints;
+            }
+            
 			my @values = defined $values ? @$values: ();
 			## Perform the checking
 			while(@type_constraints) {
@@ -591,8 +597,11 @@
 			}
 			## Make sure there are no leftovers.
 			if(@values) {
-                warn "I failed since there were left over values";
-				return;
+                if($overflow_handler) {
+                    return $overflow_handler->(@values);
+                } else {
+                    return;
+                }
 			} elsif(@type_constraints) {
                 warn "I failed due to left over TC";
 				return;
@@ -610,8 +619,14 @@
 		constraint_generator=> sub { 
 			## Get the constraints and values to check
             my ($type_constraints, $values) = @_;
-			my %type_constraints = defined $type_constraints ?
-             @$type_constraints : ();            
+			my @type_constraints = defined $type_constraints ?
+             @$type_constraints : ();
+            
+            my $overflow_handler;
+            if(ref $type_constraints[-1] eq 'CODE') {
+                $overflow_handler = pop @type_constraints;
+            } 
+            my (%type_constraints) = @type_constraints;
 			my %values = defined $values ? %$values: ();
 			## Perform the checking
 			while(%type_constraints) {
@@ -632,7 +647,11 @@
 			}
 			## Make sure there are no leftovers.
 			if(%values) { 
-				return;
+                if($overflow_handler) {
+                    return $overflow_handler->(%values);
+                } else {
+                    return;
+                }
 			} elsif(%type_constraints) {
 				return;
 			} else {

Added: MooseX-Types-Structured/trunk/t/11-overflow.t
===================================================================
--- MooseX-Types-Structured/trunk/t/11-overflow.t	                        (rev 0)
+++ MooseX-Types-Structured/trunk/t/11-overflow.t	2009-03-05 16:44:48 UTC (rev 7822)
@@ -0,0 +1,74 @@
+BEGIN {
+	use strict;
+	use warnings;
+	use Test::More tests=>20;
+}
+
+use Moose::Util::TypeConstraints;
+use MooseX::Types::Structured qw(Dict Tuple);
+use MooseX::Types::Moose qw(Int Str ArrayRef HashRef);
+
+my $array_tailed_tuple =
+    subtype 'array_tailed_tuple',
+     as Tuple[
+        Int,
+        Str,
+        sub {
+            (ArrayRef[Int])->check([@_]);
+        },
+     ];
+  
+ok !$array_tailed_tuple->check(['ss',1]), 'correct fail';
+ok $array_tailed_tuple->check([1,'ss']), 'correct pass';
+ok !$array_tailed_tuple->check({}), 'correct fail';
+ok $array_tailed_tuple->check([1,'hello',1,2,3,4]), 'correct pass with tail';
+ok !$array_tailed_tuple->check([1,'hello',1,2,'bad',4]), 'correct fail with tail';
+
+my $hash_tailed_tuple =
+    subtype 'hash_tailed_tuple',
+     as Tuple[
+       Int,
+       Str,
+       sub {
+        (HashRef[Int])->check({@_});
+       },
+     ];
+
+ok !$hash_tailed_tuple->check(['ss',1]), 'correct fail';
+ok $hash_tailed_tuple->check([1,'ss']), 'correct pass';
+ok !$hash_tailed_tuple->check({}), 'correct fail';
+ok $hash_tailed_tuple->check([1,'hello',age=>25,zip=>10533]), 'correct pass with tail';
+ok !$hash_tailed_tuple->check([1,'hello',age=>25,name=>'john']), 'correct fail with tail';
+
+my $hash_tailed_dict =
+    subtype 'hash_tailed_dict',
+    as Dict[
+      name=>Str,
+      age=>Int,
+      sub {
+        (HashRef[Int])->check({@_});        
+      }
+    ];
+    
+ok !$hash_tailed_dict->check({name=>'john',age=>'napiorkowski'}), 'correct fail';
+ok $hash_tailed_dict->check({name=>'Vanessa Li', age=>35}), 'correct pass';
+ok !$hash_tailed_dict->check([]), 'correct fail';
+ok $hash_tailed_dict->check({name=>'Vanessa Li', age=>35, more1=>1,more2=>2}), 'correct pass with tail';
+ok !$hash_tailed_dict->check({name=>'Vanessa Li', age=>35, more1=>1,more2=>"aa"}), 'correct fail with tail';
+
+my $array_tailed_dict =
+    subtype 'hash_tailed_dict',
+    as Dict[
+      name=>Str,
+      age=>Int,
+      sub {
+        (ArrayRef[Int])->check([@_]);       
+      }
+    ];
+    
+ok !$array_tailed_dict->check({name=>'john',age=>'napiorkowski'}), 'correct fail';
+ok $array_tailed_dict->check({name=>'Vanessa Li', age=>35}), 'correct pass';
+ok !$array_tailed_dict->check([]), 'correct fail';
+ok $array_tailed_dict->check({name=>'Vanessa Li', age=>35, 1,2}), 'correct pass with tail';
+ok !$array_tailed_dict->check({name=>'Vanessa Li', age=>35, 1, "hello"}), 'correct fail with tail';
+