type-coercion

diff --git a/lib/Moose.pm b/lib/Moose.pm
index b692b10..0d1068d 100644 (file)
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -95,6 +95,12 @@ sub import {
                 $options{type_constraint} = $constraint;
                        }
                }
+               if (exists $options{coerce} && $options{coerce} && $options{isa}) {
+                   my $coercion = Moose::Util::TypeConstraints::find_type_coercion($options{isa});
+                   (defined $coercion)
+                       || confess "Cannot find coercion for type " . $options{isa};
+                   $options{coerce} = $coercion;
+               }
                $meta->add_attribute($name, %options) 
        });
 

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 5c4af2f..bd16e11 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -14,6 +14,13 @@ our $VERSION = '0.02';
 use base 'Class::MOP::Attribute';
 
 Moose::Meta::Attribute->meta->add_attribute(
+    Class::MOP::Attribute->new('coerce' => (
+        reader    => 'coerce',
+        predicate => 'has_coercion'
+    )) 
+);
+
+Moose::Meta::Attribute->meta->add_attribute(
     Class::MOP::Attribute->new('weak_ref' => (
         reader    => 'weak_ref',
         predicate => {
@@ -31,6 +38,12 @@ Moose::Meta::Attribute->meta->add_attribute(
 
 Moose::Meta::Attribute->meta->add_before_method_modifier('new' => sub {
        my (undef, undef, %options) = @_;
+       if (exists $options{coerce} && $options{coerce}) {
+           (exists $options{type_constraint})
+               || confess "You cannot have coercion without specifying a type constraint";
+        confess "You cannot have a weak reference to a coerced value"
+            if $options{weak_ref};             
+       }
        (reftype($options{type_constraint}) && reftype($options{type_constraint}) eq 'CODE')
                || confess "Type cosntraint parameter must be a code-ref, not " . $options{type_constraint}
                        if exists $options{type_constraint};            
@@ -52,15 +65,29 @@ sub generate_accessor_method {
                    };                  
                }
                else {
-                   return sub {
-                               if (scalar(@_) == 2) {
-                                       (defined $self->type_constraint->($_[1]))
-                                               || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
-                                                       if defined $_[1];
-                               $_[0]->{$attr_name} = $_[1];
-                               }
-                       $_[0]->{$attr_name};
-                   };  
+                   if ($self->has_coercion) {
+                   return sub {
+                               if (scalar(@_) == 2) {
+                                   my $val = $self->coerce->($_[1]);
+                                       (defined $self->type_constraint->($val))
+                                               || confess "Attribute ($attr_name) does not pass the type contraint with '$val'"
+                                                       if defined $val;
+                               $_[0]->{$attr_name} = $val;
+                               }
+                       $_[0]->{$attr_name};
+                   };                  
+                   }
+                   else {
+                   return sub {
+                               if (scalar(@_) == 2) {
+                                       (defined $self->type_constraint->($_[1]))
+                                               || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
+                                                       if defined $_[1];
+                               $_[0]->{$attr_name} = $_[1];
+                               }
+                       $_[0]->{$attr_name};
+                   };
+                   }   
                }       
        }
        else {
@@ -155,6 +182,10 @@ extensions.
 
 =item B<weak_ref>
 
+=item B<coerce>
+
+=item B<has_coercion>
+
 =back
 
 =head1 BUGS

diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index f21e348..f9fa401 100644 (file)
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -15,7 +15,7 @@ sub import {
        my $pkg = shift || caller();
        return if $pkg eq ':no_export';
        no strict 'refs';
-       foreach my $export (qw(type subtype coerce as where to)) {
+       foreach my $export (qw(type subtype as where to coerce)) {
                *{"${pkg}::${export}"} = \&{"${export}"};
        }       
 }
@@ -32,6 +32,12 @@ sub import {
         $TYPES{$type_name} = $type_constraint;
     }
     
+    sub dump_type_constraints {
+        require Data::Dumper;
+        $Data::Dumper::Deparse = 1;
+        Data::Dumper::Dumper(\%TYPES);
+    }
+    
     sub export_type_contstraints_as_functions {
         my $pkg = caller();
            no strict 'refs';
@@ -91,8 +97,10 @@ sub subtype ($$;$) {
        }
 }
 
-sub coerce {
+sub coerce ($@) {
     my ($type_name, @coercion_map) = @_;
+    #use Data::Dumper;
+    #warn Dumper \@coercion_map;    
     my @coercions;
     while (@coercion_map) {
         my ($constraint_name, $action) = splice(@coercion_map, 0, 2);
@@ -206,6 +214,8 @@ Suggestions for improvement are welcome.
 
 =item B<export_type_contstraints_as_functions>
 
+=item B<dump_type_constraints>
+
 =back
 
 =head2 Type Constraint Constructors

diff --git a/t/005_basic.t b/t/005_basic.t
new file mode 100644 (file)
index 0000000..3695fac
--- /dev/null
+++ b/t/005_basic.t
@@ -0,0 +1,73 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+use Test::Exception;
+
+use Scalar::Util 'isweak';
+
+BEGIN {
+    use_ok('Moose');           
+}
+
+{
+    package HTTPHeader;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    has 'array' => (is => 'ro');
+    has 'hash'  => (is => 'ro');    
+
+    package Engine;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    coerce 'HTTPHeader'
+        => as ArrayRef 
+            => to { HTTPHeader->new(array => $_[0]) }
+        => as HashRef 
+            => to { HTTPHeader->new(hash => $_[0]) };    
+    
+    has 'header' => (is => 'rw', isa => 'HTTPHeader', coerce => 1);    
+}
+
+my $engine = Engine->new();
+isa_ok($engine, 'Engine');
+
+# try with arrays
+
+$engine->header([ 1, 2, 3 ]);
+isa_ok($engine->header, 'HTTPHeader');
+
+is_deeply(
+    $engine->header->array,
+    [ 1, 2, 3 ],
+    '... got the right array value of the header');
+ok(!defined($engine->header->hash), '... no hash value set');
+
+# try with hash
+
+$engine->header({ one => 1, two => 2, three => 3 });
+isa_ok($engine->header, 'HTTPHeader');
+
+is_deeply(
+    $engine->header->hash,
+    { one => 1, two => 2, three => 3 },
+    '... got the right hash value of the header');
+ok(!defined($engine->header->array), '... no array value set');
+
+dies_ok {
+   $engine->header("Foo"); 
+} '... dies with the wrong type, even after coercion';
+
+lives_ok {
+   $engine->header(HTTPHeader->new); 
+} '... lives with the right type, even after coercion';
+
+
+
+

diff --git a/t/053_util_find_type_constraint.t b/t/053_util_find_type_constraint.t
index 242abf9..b3dc1e0 100644 (file)
--- a/t/053_util_find_type_constraint.t
+++ b/t/053_util_find_type_constraint.t
@@ -10,3 +10,4 @@ BEGIN {
        use_ok('Moose::Util::TypeConstraints', (':no_export'));
 }
 
+#diag Moose::Util::TypeConstraints::dump_type_constraints();
\ No newline at end of file