From: 大沢 和宏 <yappo@shibuya.pl>
Date: Tue, 2 Dec 2008 10:26:12 +0000 (+0000)
Subject: added to coerce feature
X-Git-Tag: 0.19~136^2~84
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4188b837041f2d3b244daf2c57ddecca151e7418;p=gitmo%2FMouse.git

added to coerce feature
---

diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm
index 94bb535..5a43c4d 100644
--- a/lib/Mouse/Meta/Attribute.pm
+++ b/lib/Mouse/Meta/Attribute.pm
@@ -36,6 +36,7 @@ sub type_constraint   { $_[0]->{type_constraint}  }
 sub trigger           { $_[0]->{trigger}          }
 sub builder           { $_[0]->{builder}          }
 sub should_auto_deref { $_[0]->{auto_deref}       }
+sub is_coerce         { $_[0]->{is_coerce}        }
 
 sub has_default         { exists $_[0]->{default}         }
 sub has_predicate       { exists $_[0]->{predicate}       }
@@ -68,6 +69,7 @@ sub generate_accessor {
     my $trigger      = $attribute->trigger;
     my $is_weak      = $attribute->is_weak_ref;
     my $should_deref = $attribute->should_auto_deref;
+    my $is_coerce    = $attribute->is_coerce;
 
     my $self  = '$_[0]';
     my $key   = $attribute->inlined_name;
@@ -79,7 +81,11 @@ sub generate_accessor {
         my $value = '$_[1]';
 
         if ($constraint) {
-            $accessor .= 'local $_ = '.$value.';
+            if ($is_coerce) {
+                $accessor .= $value.' = $attribute->coerce_constraint('.$value.');';
+            }
+            $accessor .= 'local $_ = '.$value.';';
+            $accessor .= '
                 unless ($constraint->()) {
                     my $display = defined($_) ? overload::StrVal($_) : "undef";
                     Carp::confess("Attribute ($name) does not pass the type constraint because: Validation failed for \'$type\' failed with value $display");
@@ -191,6 +197,9 @@ sub create {
     %args = $self->canonicalize_args($name, %args);
     $self->validate_args($name, \%args);
 
+    $args{is_coerce} = delete $args{coerce}
+        if exists $args{coerce};
+
     $args{type_constraint} = delete $args{isa}
         if exists $args{isa};
 
@@ -291,7 +300,7 @@ sub find_type_constraint {
 
     return unless $type;
 
-    my $checker = Mouse::TypeRegistry->optimized_constraints->{$type};
+    my $checker = Mouse::TypeRegistry->optimized_constraints($self->associated_class->name)->{$type};
     return $checker if $checker;
 
     return sub { blessed($_) && blessed($_) eq $type };
@@ -312,6 +321,13 @@ sub verify_type_constraint {
     Carp::confess("Attribute ($name) does not pass the type constraint because: Validation failed for \'$type\' failed with value $display");
 }
 
+sub coerce_constraint {
+    my($self, $value) = @_;
+    my $type = $self->type_constraint
+        or return $value;
+    return Mouse::TypeRegistry->typecast_constraints($self->associated_class->name, $type, $value);
+}
+
 sub _canonicalize_handles {
     my $self    = shift;
     my $handles = shift;
diff --git a/lib/Mouse/Object.pm b/lib/Mouse/Object.pm
index 8c36df3..0c57594 100644
--- a/lib/Mouse/Object.pm
+++ b/lib/Mouse/Object.pm
@@ -19,6 +19,8 @@ sub new {
         my $default;
 
         if (defined($from) && exists($args->{$from})) {
+            $args->{$from} = $attribute->coerce_constraint($args->{$from})
+                if $attribute->is_coerce;
             $attribute->verify_type_constraint($args->{$from})
                 if $attribute->has_type_constraint;
 
@@ -42,6 +44,8 @@ sub new {
                                   ? $default->()
                                   : $default;
 
+                    $value = $attribute->coerce_constraint($value)
+                        if $attribute->is_coerce;
                     $attribute->verify_type_constraint($value)
                         if $attribute->has_type_constraint;
 
diff --git a/lib/Mouse/TypeRegistry.pm b/lib/Mouse/TypeRegistry.pm
index 1aef7a8..32bd435 100644
--- a/lib/Mouse/TypeRegistry.pm
+++ b/lib/Mouse/TypeRegistry.pm
@@ -5,9 +5,75 @@ use warnings;
 
 use Mouse::Util qw/blessed looks_like_number openhandle/;
 
-no warnings 'uninitialized';
-sub optimized_constraints {
-    return {
+my $SUBTYPE = +{};
+my $COERCE = +{};
+
+sub import {
+    my $class  = shift;
+    my %args   = @_;
+    my $caller = caller(0);
+
+    $SUBTYPE->{$caller} ||= +{};
+    $COERCE->{$caller}  ||= +{};
+
+    if (defined $args{'-export'} && ref($args{'-export'}) eq 'ARRAY') {
+        no strict 'refs';
+        *{"$caller\::import"} = sub { _import(@_) };
+    }
+
+    no strict 'refs';
+    *{"$caller\::subtype"}     = \&_subtype;
+    *{"$caller\::coerce"}      = \&_coerce;
+#    *{"$caller\::class_type"}  = \&_class_type;
+#    *{"$caller\::role_type"}   = \&_role_type;
+}
+
+sub _import {
+    my($class, @types) = @_;
+    return unless exists $SUBTYPE->{$class} && exists $COERCE->{$class};
+    my $pkg = caller(1);
+    return unless @types;
+    copy_types($class, $pkg, @types);
+}
+
+sub _subtype {
+    my $pkg = caller(0);
+    my($name, $stuff) = @_;
+    if (ref $stuff eq 'HASH') {
+        my $as = $stuff->{as};
+        $stuff = optimized_constraints()->{$as};
+    }
+    $SUBTYPE->{$pkg}->{$name} = $stuff;
+}
+
+sub _coerce {
+    my $pkg = caller(0);
+    my($name, $conf) = @_;
+    $COERCE->{$pkg}->{$name} = $conf;
+}
+
+use Data::Dumper;
+sub typecast_constraints {
+    my($class, $pkg, $type, $value) = @_;
+    return $value unless defined $COERCE->{$pkg} && defined $COERCE->{$pkg}->{$type};
+
+    my $optimized_constraints = optimized_constraints();
+    for my $coerce_type (keys %{ $COERCE->{$pkg}->{$type} }) {
+        local $_ = $value;
+        if ($optimized_constraints->{$coerce_type}->()) {
+            local $_ = $value;
+            return $COERCE->{$pkg}->{$type}->{$coerce_type}->();
+        }
+    }
+
+
+warn Dumper($COERCE);
+    return $value;
+}
+
+{
+    no warnings 'uninitialized';
+    my $optimized_constraints = {
         Any        => sub { 1 },
         Item       => sub { 1 },
         Bool       => sub {
@@ -39,6 +105,11 @@ sub optimized_constraints {
 
         Object     => sub { blessed($_) && blessed($_) ne 'Regexp' },
     };
+    sub optimized_constraints {
+        my($class, $pkg) = @_;
+        my $subtypes = $SUBTYPE->{$pkg} || {};
+        return { %{ $subtypes }, %{ $optimized_constraints } };
+    }
 }
 
 1;