Changeset 25424

Timestamp:

11/30/08 18:14:50 (4 years ago)

Author:

yappo

Message:

refactoring to coerce

Location:

lang/perl/Shika/trunk

Files:

• lib/Shika.pm (modified) (5 diffs)
• lib/Shika/Devel.pm (modified) (3 diffs)
• lib/Shika/Devel/TypeConstraints.pm (modified) (4 diffs)
• t/010_core/08_coerce.t (modified) (1 diff)
• tools/accessor_installer_generator.pl (modified) (2 diffs)

lang/perl/Shika/trunk/lib/Shika.pm

@@ -73 +73 @@
             next unless exists $args->{$name};
             next unless exists $has->{coerce} && $has->{coerce};
-            Carp::croak "Shika requires CODE for cerce" unless ref $has->{coerce} eq 'CODE';
-            $args->{$name} = $has->{coerce}->($args->{$name});
+            die "does not pass the type constraint because: Validation failed for '$has->{isa}' failed $name"
+                unless Shika::Devel::TypeConstraints::check_valid($has, undef, $args->{$name});
         }
         # process 'required'
@@ -98 +98 @@
 sub add_attribute {
     my ($target, $name, $attr) = @_;
+
+    die "You cannot have coercion without specifying a type constraint on attribute ($name)"
+        if $attr->{coerce} && !$attr->{isa};
 
     no strict 'refs';
@@ -159 +162 @@
         }
 
+        if (exists $has->{isa}) {
+            die "does not pass the type constraint because: Validation failed for '$has->{isa}' failed $_[0]"
+                unless Shika::Devel::TypeConstraints::check_valid($has, @_);
+        }
+
         if (@_==2) { 
-            return $_[0]->{$n} = $has->{coerce}->($_[1]);
+            return $_[0]->{$n} = $_[1];
         }
         shift->{$n} = \@_;
@@ -197 +205 @@
         }
 
+        if (exists $has->{isa}) {
+            die "does not pass the type constraint because: Validation failed for '$has->{isa}' failed $_[0]"
+                unless Shika::Devel::TypeConstraints::check_valid($has, @_);
+        }
+
         if (@_==2) { 
-            return $_[0]->{$n} = $has->{coerce}->($_[1]);
+            return $_[0]->{$n} = $_[1];
         }
         shift->{$n} = \@_;
@@ -237 +250 @@
         }
 
+        if (exists $has->{isa}) {
+            die "does not pass the type constraint because: Validation failed for '$has->{isa}' failed $_[0]"
+                unless Shika::Devel::TypeConstraints::check_valid($has, @_);
+        }
+
         if (@_==2) { 
-            return $_[0]->{$n} = $has->{coerce}->($_[1]);
+            return $_[0]->{$n} = $_[1];
         }
         shift->{$n} = \@_;

lang/perl/Shika/trunk/lib/Shika/Devel.pm

@@ -64 +64 @@
 
         if (@_==2) { 
-            return $_[0]->{$n} = $has->{coerce}->($_[1]);
+            return $_[0]->{$n} = $_[1];
         }
         shift->{$n} = \@_;
@@ -112 +112 @@
 
         if (@_==2) { 
-            return $_[0]->{$n} = $has->{coerce}->($_[1]);
+            return $_[0]->{$n} = $_[1];
         }
         shift->{$n} = \@_;
@@ -162 +162 @@
 
         if (@_==2) { 
-            return $_[0]->{$n} = $has->{coerce}->($_[1]);
+            return $_[0]->{$n} = $_[1];
         }
         shift->{$n} = \@_;

lang/perl/Shika/trunk/lib/Shika/Devel/TypeConstraints.pm

@@ -2 +2 @@
 use strict;
 use warnings;
+
+my @DEFAULT_TYPES = qw( Any Bool Maybe Undef Defined Value Num Int Str ClassName Ref ScalarRef ArrayRef HashRef CodeRef GlobeRef FileHandle Object Role );
 
 sub import {
@@ -9 +11 @@
     no strict 'refs';
     *{"$caller\::subtype"} = \&_subtype;
+    *{"$caller\::coerce"}  = \&_coerce;
 }
 
@@ -15 +18 @@
     my($name, $code) = @_;
     $SUBTYPE->{$name} = $code;
+}
+
+my $COERCE = +{};
+sub _coerce {
+    my($name, $conf) = @_;
+    $COERCE->{$name} = $conf;
+}
+
+sub _apply_coerce {
+    my $isa = shift;
+
+    my @types = ( $isa );
+    if ($isa =~ /\|/) { # or
+        $isa =~ s/\s//g;
+        for my $type (split /\|/, $isa) {
+            push @types, $type;
+        }
+    }
+
+    my $arg_type;
+    while (my($type, $code) = each %{ $SUBTYPE }) {
+        next unless $code->(@_);
+        $arg_type = $type;
+        last;
+    }
+    unless ($arg_type) {
+        for my $type (reverse @DEFAULT_TYPES) {
+            next unless eval { _check($type, @_) };
+            $arg_type = $type;
+            last;
+        }
+    }
+
+    for my $type (@types) {
+        next unless defined $COERCE->{$type};
+        next unless defined $COERCE->{$type}->{$arg_type};
+        $COERCE->{$type}->{$arg_type}->(@_);
+        return _check($isa, @_);
+    }
 }
 
@@ -24 +66 @@
     return 1 unless $isa;
     return 1 if @_ > 1 && $isa eq 'ARRAY';
-    return _check($isa, @_);
+    _check($isa, @_) ? 1 : $has->{coerce} ? _apply_coerce($isa, @_) : 0;
 }
 

lang/perl/Shika/trunk/t/010_core/08_coerce.t

@@ -12 +12 @@
     package Response;
     use Shika;
+    use Shika::Devel::TypeConstraints;
+
+    subtype 'Headers' => sub { defined $_[0] && eval { $_[0]->isa('Headers') } };
+    coerce 'Headers' => +{
+        HashRef => sub {
+            $_[0] = Headers->new(%{ $_[0] });
+        },
+    };
+
     has headers => (
-        coerce => sub {
-            my $param = shift;
-            if (ref $param eq 'HASH') {
-                Headers->new(%$param)
-            } else {
-                $param
-            }
-        },
+        isa    => 'Headers',
+        coerce => 1,
     );
 }
 
-my $r = Response->new(headers => { foo => 'bar'});
+my $r = Response->new(headers => { foo => 'bar' });
 is($r->headers->foo, 'bar');
 $r->headers({foo => 'yay'});

lang/perl/Shika/trunk/tools/accessor_installer_generator.pl

@@ -32 +32 @@
         }
 
-[% IF debug -%]
+[% IF debug || coerce -%]
         if (exists $has->{isa}) {
             die "does not pass the type constraint because: Validation failed for '$has->{isa}' failed $_[0]"
@@ -40 +40 @@
 [% END -%]
         if (@_==2) { [%# setter %]
-[% IF coerce -%]
-            return $_[0]->{$n} = $has->{coerce}->($_[1]);
-[% ELSE -%]
             return $_[0]->{$n} = $_[1];
-[% END -%]
         }
         shift->{$n} = \@_;