From: Shawn M Moore <sartak@gmail.com>
Date: Wed, 5 Dec 2007 01:15:45 +0000 (+0000)
Subject: Add support for parametric containers that subtype ArrayRef or HashRef
X-Git-Tag: 0_33~9
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=39aba5c9fd57a65a61c4612d36dc0956a917e8e0;p=gitmo%2FMoose.git

Add support for parametric containers that subtype ArrayRef or HashRef
---

diff --git a/Changes b/Changes
index 2798d0d..9248076 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,10 @@
 Revision history for Perl extension Moose
 
+0.33
+    * Moose::Meta::TypeConstraint::Parameterized
+      - allow subtypes of ArrayRef and HashRef to
+        be used as a container
+
 0.32 Tues. Dec. 4, 2007
     * Moose::Util::TypeConstraints
       - fixing how subtype aliases of unions work
diff --git a/lib/Moose/Meta/TypeConstraint/Parameterized.pm b/lib/Moose/Meta/TypeConstraint/Parameterized.pm
index 1eaba7d..f47efa4 100644
--- a/lib/Moose/Meta/TypeConstraint/Parameterized.pm
+++ b/lib/Moose/Meta/TypeConstraint/Parameterized.pm
@@ -30,24 +30,26 @@ sub compile_type_constraint {
     
     my $constraint;
     
-    my $parent_name = $self->parent->name;
-    
-    if ($parent_name eq 'ArrayRef') {
-        $constraint = sub {
-            foreach my $x (@$_) { 
-                ($type_parameter->check($x)) || return 
-            } 1;
-        };
+    my $array_constraint = sub {
+        foreach my $x (@$_) {
+            ($type_parameter->check($x)) || return
+        } 1;
+    };
+
+    my $hash_constraint = sub {
+        foreach my $x (values %$_) {
+            ($type_parameter->check($x)) || return
+        } 1;
+    };
+
+    if ($self->is_subtype_of('ArrayRef')) {
+        $constraint = $array_constraint;
     }
-    elsif ($parent_name eq 'HashRef') {
-        $constraint = sub {
-            foreach my $x (values %$_) { 
-                ($type_parameter->check($x)) || return 
-            } 1;
-        };          
+    elsif ($self->is_subtype_of('HashRef')) {
+        $constraint = $hash_constraint;
     }
     else {
-        confess "Your isa must be either ArrayRef or HashRef (sorry no subtype support yet)";
+        confess "The " . $self->name . " constraint cannot be used, because " . $self->parent->name . " doesn't subtype ArrayRef or HashRef.";
     }
     
     $self->_set_constraint($constraint);
diff --git a/t/040_type_constraints/018_custom_parameterized_types.t b/t/040_type_constraints/018_custom_parameterized_types.t
new file mode 100644
index 0000000..0649653
--- /dev/null
+++ b/t/040_type_constraints/018_custom_parameterized_types.t
@@ -0,0 +1,85 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 21;
+use Test::Exception;
+
+BEGIN {
+    use_ok("Moose::Util::TypeConstraints");
+    use_ok('Moose::Meta::TypeConstraint::Parameterized');
+}
+
+lives_ok {
+    subtype 'AlphaKeyHash' => as 'HashRef'
+        => where {
+            # no keys match non-alpha
+            (grep { /[^a-zA-Z]/ } keys %$_) == 0
+        };
+} '... created the subtype special okay';
+
+lives_ok {
+    subtype 'Trihash' => as 'AlphaKeyHash'
+        => where {
+            keys(%$_) == 3
+        };
+} '... created the subtype special okay';
+
+lives_ok {
+    subtype 'Noncon' => as 'Item';
+} '... created the subtype special okay';
+
+{
+    my $t = find_type_constraint('AlphaKeyHash');
+    isa_ok($t, 'Moose::Meta::TypeConstraint');
+
+    is($t->name, 'AlphaKeyHash', '... name is correct');
+
+    my $p = $t->parent;
+    isa_ok($p, 'Moose::Meta::TypeConstraint');
+
+    is($p->name, 'HashRef', '... parent name is correct');
+
+    ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
+    ok(!$t->check({ one1 => 1, two2 => 2 }), '... validated it correctly');
+}
+
+my $hoi = Moose::Meta::TypeConstraint::Parameterized->new(
+    name           => 'AlphaKeyHash[Int]',
+    parent         => find_type_constraint('AlphaKeyHash'),
+    type_parameter => find_type_constraint('Int'),
+);
+
+ok($hoi->check({ one => 1, two => 2 }), '... validated it correctly');
+ok(!$hoi->check({ one1 => 1, two2 => 2 }), '... validated it correctly');
+ok(!$hoi->check({ one => 'uno', two => 'dos' }), '... validated it correctly');
+ok(!$hoi->check({ one1 => 'un', two2 => 'deux' }), '... validated it correctly');
+
+my $th = Moose::Meta::TypeConstraint::Parameterized->new(
+    name           => 'Trihash[Bool]',
+    parent         => find_type_constraint('Trihash'),
+    type_parameter => find_type_constraint('Bool'),
+);
+
+ok(!$th->check({ one => 1, two => 1 }), '... validated it correctly');
+ok($th->check({ one => 1, two => 0, three => 1 }), '... validated it correctly');
+ok(!$th->check({ one => 1, two => 2, three => 1 }), '... validated it correctly');
+ok(!$th->check({foo1 => 1, bar2 => 0, baz3 => 1}), '... validated it correctly');
+
+dies_ok {
+    Moose::Meta::TypeConstraint::Parameterized->new(
+        name           => 'Str[Int]',
+        parent         => find_type_constraint('Str'),
+        type_parameter => find_type_constraint('Int'),
+    );
+} 'non-containers cannot be parameterized';
+
+dies_ok {
+    Moose::Meta::TypeConstraint::Parameterized->new(
+        name           => 'Noncon[Int]',
+        parent         => find_type_constraint('Noncon'),
+        type_parameter => find_type_constraint('Int'),
+    );
+} 'non-containers cannot be parameterized';
+