From: Shawn M Moore <sartak@gmail.com>
Date: Wed, 5 Dec 2007 01:55:55 +0000 (+0000)
Subject: Add some support for coercing to ArrayRef or HashRef for collection purposes
X-Git-Tag: 0_33~8
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=acb8a5dbf003dd584c09b3e62f24484ccdeeeb80;p=gitmo%2FMoose.git

Add some support for coercing to ArrayRef or HashRef for collection purposes
---

diff --git a/Changes b/Changes
index 9248076..e8008bc 100644
--- a/Changes
+++ b/Changes
@@ -3,7 +3,9 @@ Revision history for Perl extension Moose
 0.33
     * Moose::Meta::TypeConstraint::Parameterized
       - allow subtypes of ArrayRef and HashRef to
-        be used as a container
+        be used as a container (sartak)
+      - basic support for coercion to ArrayRef and
+        HashRef for containers (sartak)
 
 0.32 Tues. Dec. 4, 2007
     * Moose::Util::TypeConstraints
diff --git a/lib/Moose/Meta/TypeConstraint/Parameterized.pm b/lib/Moose/Meta/TypeConstraint/Parameterized.pm
index f47efa4..68d1b4d 100644
--- a/lib/Moose/Meta/TypeConstraint/Parameterized.pm
+++ b/lib/Moose/Meta/TypeConstraint/Parameterized.pm
@@ -6,6 +6,7 @@ use metaclass;
 
 use Scalar::Util 'blessed';
 use Carp         'confess';
+use Moose::Util::TypeConstraints;
 
 our $VERSION   = '0.01';
 our $AUTHORITY = 'cpan:STEVAN';
@@ -29,7 +30,16 @@ sub compile_type_constraint {
         || confess "The type parameter must be a Moose meta type";
     
     my $constraint;
-    
+    my $name = $self->parent->name;
+
+    my $array_coercion =
+        Moose::Util::TypeConstraints::find_type_constraint('ArrayRef')
+        ->coercion;
+
+    my $hash_coercion =
+        Moose::Util::TypeConstraints::find_type_constraint('HashRef')
+        ->coercion;
+
     my $array_constraint = sub {
         foreach my $x (@$_) {
             ($type_parameter->check($x)) || return
@@ -48,8 +58,20 @@ sub compile_type_constraint {
     elsif ($self->is_subtype_of('HashRef')) {
         $constraint = $hash_constraint;
     }
+    elsif ($array_coercion && $array_coercion->has_coercion_for_type($name)) {
+        $constraint = sub {
+            local $_ = $array_coercion->coerce($_);
+            $array_constraint->(@_);
+        };
+    }
+    elsif ($hash_coercion && $hash_coercion->has_coercion_for_type($name)) {
+        $constraint = sub {
+            local $_ = $hash_coercion->coerce($_);
+            $hash_constraint->(@_);
+        };
+    }
     else {
-        confess "The " . $self->name . " constraint cannot be used, because " . $self->parent->name . " doesn't subtype ArrayRef or HashRef.";
+        confess "The " . $self->name . " constraint cannot be used, because " . $name . " doesn't subtype or coerce ArrayRef or HashRef.";
     }
     
     $self->_set_constraint($constraint);
diff --git a/t/040_type_constraints/019_coerced_parameterized_types.t b/t/040_type_constraints/019_coerced_parameterized_types.t
new file mode 100644
index 0000000..8c0d57c
--- /dev/null
+++ b/t/040_type_constraints/019_coerced_parameterized_types.t
@@ -0,0 +1,66 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 11;
+use Test::Exception;
+
+BEGIN {
+    use_ok("Moose::Util::TypeConstraints");
+    use_ok('Moose::Meta::TypeConstraint::Parameterized');
+}
+
+BEGIN {
+    package MyList;
+    sub new {
+        my $class = shift;
+        bless { items => \@_ }, $class;
+    }
+
+    sub items {
+        my $self = shift;
+        return @{ $self->{items} };
+    }
+}
+
+subtype 'MyList' => as 'Object' => where { $_->isa('MyList') };
+
+lives_ok {
+    coerce 'ArrayRef'
+        => from 'MyList'
+            => via { [ $_->items ] }
+} '... created the coercion okay';
+
+my $mylist = Moose::Meta::TypeConstraint::Parameterized->new(
+    name           => 'MyList[Int]',
+    parent         => find_type_constraint('MyList'),
+    type_parameter => find_type_constraint('Int'),
+);
+
+ok($mylist->check(MyList->new(10, 20, 30)), '... validated it correctly');
+ok(!$mylist->check(MyList->new(10, "two")), '... validated it correctly');
+ok(!$mylist->check([10]), '... validated it correctly');
+
+subtype 'EvenList' => as 'MyList' => where { $_->items % 2 == 0 };
+
+# XXX: get this to work *without* the declaration. I suspect it'll be a new
+# method in Moose::Meta::TypeCoercion that will look at the parents of the
+# coerced type as well. but will that be too "action at a distance"-ey?
+lives_ok {
+    coerce 'ArrayRef'
+        => from 'EvenList'
+            => via { [ $_->items ] }
+} '... created the coercion okay';
+
+my $evenlist = Moose::Meta::TypeConstraint::Parameterized->new(
+    name           => 'EvenList[Int]',
+    parent         => find_type_constraint('EvenList'),
+    type_parameter => find_type_constraint('Int'),
+);
+
+ok(!$evenlist->check(MyList->new(10, 20, 30)), '... validated it correctly');
+ok($evenlist->check(MyList->new(10, 20, 30, 40)), '... validated it correctly');
+ok(!$evenlist->check(MyList->new(10, "two")), '... validated it correctly');
+ok(!$evenlist->check([10, 20]), '... validated it correctly');
+