positional and named constraints

diff --git a/lib/MooseX/Meta/TypeConstraint/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Structured.pm
index 0bfde1b..e77704a 100644 (file)
--- a/lib/MooseX/Meta/TypeConstraint/Structured.pm
+++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm
@@ -43,9 +43,27 @@ contraint container.
 
 =cut
 
+subtype 'MooseX::Meta::TypeConstraint::Structured::Signature',
+    as 'HashRef[Object]',
+    where {
+        my %signature = %$_;
+        foreach my $key (keys %signature) {
+            $signature{$key}->isa('Moose::Meta::TypeConstraint');
+        } 1;
+    };
+ 
+coerce 'MooseX::Meta::TypeConstraint::Structured::Signature',
+    from 'ArrayRef[Object]',
+    via {
+        my @signature = @$_;
+        my %hashed_signature = map { $_ => $signature[$_] } 0..$#signature;
+        \%hashed_signature;
+    };
+
 has 'signature' => (
     is=>'ro',
-    isa=>'Ref',
+    isa=>'MooseX::Meta::TypeConstraint::Structured::Signature',
+    coerce=>1,
     required=>1,
 );
 
@@ -55,16 +73,23 @@ This class defines the following methods.
 
 =head2 _normalize_args
 
-Get arguments into a known state or die trying
+Get arguments into a known state or die trying.  Ideally we try to make this
+into a HashRef so we can match it up with the L</signature> HashRef.
 
 =cut
 
 sub _normalize_args {
     my ($self, $args) = @_;
-    if(defined $args && ref $args eq 'ARRAY') {
-        return @{$args};
+    if(defined $args) {
+        if(ref $args eq 'ARRAY') {
+            return map { $_ => $args->[$_] } (0..$#$args);
+        } elsif (ref $args eq 'HASH') {
+            return %$args;
+        } else {
+            confess 'Signature must be a reference';
+        }
     } else {
-        confess 'Arguments not ArrayRef as expected.';
+        confess 'Signature cannot be empty';
     }
 }
     
@@ -77,15 +102,56 @@ The constraint is basically validating the L</signature> against the incoming
 sub constraint {
     my $self = shift;
     return sub {
-        my @args = $self->_normalize_args(shift);
-        foreach my $idx (0..$#args) {
-            if(my $error = $self->signature->[$idx]->validate($args[$idx])) {
+        my %args = $self->_normalize_args(shift);
+        foreach my $idx (keys %{$self->signature}) {
+            my $type_constraint = $self->signature->{$idx};
+            if(my $error = $type_constraint->validate($args{$idx})) {
                 confess $error;
             }
         } 1;        
     };
 }
 
+=head2 equals
+
+modifier to make sure equals descends into the L</signature>
+
+=cut
+
+around 'equals' => sub {
+    my ($equals, $self, $compared_type_constraint) = @_;
+    
+    ## Make sure we are comparing typeconstraints of the same base class
+    return unless $compared_type_constraint->isa(__PACKAGE__);
+    
+    ## Make sure the base equals is also good
+    return unless $self->$equals($compared_type_constraint);
+    
+    ## Make sure the signatures match
+    return unless $self->signature_equals($compared_type_constraint);
+   
+    ## If we get this far, the two are equal
+    return 1;
+};
+
+=head2 signature_equals
+
+Check that the signature equals another signature.
+
+=cut
+
+sub signature_equals {
+    my ($self, $compared_type_constraint) = @_;
+    
+   foreach my $idx (keys %{$self->signature}) {
+        my $this = $self->signature->{$idx};
+        my $that = $compared_type_constraint->signature->{$idx};
+        return unless $this->equals($that);
+    }
+   
+    return 1;
+}
+
 =head1 AUTHOR
 
 John James Napiorkowski <jjnapiork@cpan.org>

diff --git a/t/constraints.t b/t/constraints.t
index dae3e09..8a3c2b0 100644 (file)
--- a/t/constraints.t
+++ b/t/constraints.t
@@ -1,12 +1,12 @@
 BEGIN {
        use strict;
        use warnings;
-       use Test::More tests=>8;
+       use Test::More tests=>12;
        use Test::Exception;
 }
 
 {
-    package Test::MooseX::Meta::TypeConstraint::Structured::Positional;
+    package Test::MooseX::Meta::TypeConstraint::Structured;
 
     use Moose;
     use Moose::Util::TypeConstraints;
@@ -17,26 +17,39 @@ BEGIN {
      where { $_=~m/abc/};
       
     sub Tuple {
-        my $args = shift @_;
+        my @args = @{shift @_};
         return MooseX::Meta::TypeConstraint::Structured->new(
             name => 'Tuple',
             parent => find_type_constraint('ArrayRef'),
             package_defined_in => __PACKAGE__,
-            signature => [map {find_type_constraint($_)} @$args],
+            signature => [map {find_type_constraint($_)} @args],
+        );
+    }
+       
+    sub Dict {
+        my %args = @{shift @_};
+        return MooseX::Meta::TypeConstraint::Structured->new(
+            name => 'Tuple',
+            parent => find_type_constraint('HashRef'),
+            package_defined_in => __PACKAGE__,
+            signature => {map { $_ => find_type_constraint($args{$_})} keys %args},
         );
     }
 
     has 'tuple' => (is=>'rw', isa=>Tuple['Int', 'Str', 'MyString']);
+    has 'dict' => (is=>'rw', isa=>Dict[name=>'Str', age=>'Int']);
 }
 
 ## Instantiate a new test object
 
-ok my $record = Test::MooseX::Meta::TypeConstraint::Structured::Positional->new
+ok my $record = Test::MooseX::Meta::TypeConstraint::Structured->new
  => 'Instantiated new Record test class.';
  
-isa_ok $record => 'Test::MooseX::Meta::TypeConstraint::Structured::Positional'
+isa_ok $record => 'Test::MooseX::Meta::TypeConstraint::Structured'
  => 'Created correct object type.';
 
+## Test Tuple type constraint
+
 lives_ok sub {
     $record->tuple([1,'hello', 'test.abc.test']);
 } => 'Set tuple attribute without error';
@@ -60,3 +73,19 @@ throws_ok sub {
 }, qr/Validation failed for 'Int'/
  => 'Got Expected Error for violating constraints';
 
+## Test the Dictionary type constraint
+ 
+lives_ok sub {
+    $record->dict({name=>'frith', age=>23});
+} => 'Set dict attribute without error';
+
+is $record->dict->{name}, 'frith'
+ => 'correct set the dict attribute name';
+
+is $record->dict->{age}, 23
+ => 'correct set the dict attribute age';
+ 
+throws_ok sub {
+    $record->dict({name=>[1,2,3], age=>'sdfsdfsd'});      
+}, qr/Validation failed for 'Str'/
+ => 'Got Expected Error for bad value in dict';