X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FUtil%2FTypeConstraints.pm;h=6a9ee5777b849079cd99f50d084a8989fa809ec2;hb=766534c221078e4e10d66fcc2aca0563aad54f4e;hp=dc569a9b7321469a9329b3c8ffe625270b803ed5;hpb=ccf442276cab228f5346a4ba2aa90268941a0ecf;p=gitmo%2FMouse.git

diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm
index dc569a9..6a9ee57 100644
--- a/lib/Mouse/Util/TypeConstraints.pm
+++ b/lib/Mouse/Util/TypeConstraints.pm
@@ -5,6 +5,7 @@ use base 'Exporter';
 
 use Carp ();
 use Scalar::Util qw/blessed looks_like_number openhandle/;
+use Mouse::Meta::TypeConstraint;
 
 our @EXPORT = qw(
     as where message from via type subtype coerce class_type role_type enum
@@ -63,8 +64,8 @@ BEGIN {
 
         Object     => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' },
     );
-    foreach my $code (values %TYPE) {
-        bless $code, 'Mouse::Meta::TypeConstraint';
+    while (my ($name, $code) = each %TYPE) {
+        $TYPE{$name} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $name );
     }
 
     sub optimized_constraints { \%TYPE }
@@ -89,7 +90,17 @@ sub type {
     };
 
     $TYPE_SOURCE{$name} = $pkg;
-    $TYPE{$name} = sub { local $_ = $_[0]; $constraint->($_[0]) };
+    $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
+        name => $name,
+        _compiled_type_constraint => sub {
+            local $_ = $_[0];
+            if (ref $constraint eq 'CODE') {
+                $constraint->($_[0])
+            } else {
+                $constraint->check($_[0])
+            }
+        }
+    );
 }
 
 sub subtype {
@@ -102,16 +113,20 @@ sub subtype {
     my $as_constraint = find_or_create_isa_type_constraint($conf{as} || 'Any');
 
     $TYPE_SOURCE{$name} = $pkg;
-    $TYPE{$name} = $constraint ? 
-        sub {
-            local $_ = $_[0];
-            $as_constraint->($_[0]) && $constraint->($_[0])
-        } :
-        sub {
-            local $_ = $_[0];
-            $as_constraint->($_[0]);
-        }
-    ;
+    $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
+        name => $name,
+        _compiled_type_constraint => (
+            $constraint ? 
+            sub {
+                local $_ = $_[0];
+                $as_constraint->check($_[0]) && $constraint->($_[0])
+            } :
+            sub {
+                local $_ = $_[0];
+                $as_constraint->check($_[0]);
+            }
+        ),
+    );
 
     return $name;
 }
@@ -133,7 +148,7 @@ sub coerce {
         if (! $TYPE{$type}) {
             # looks parameterized
             if ($type =~ /^[^\[]+\[.+\]$/) {
-                _build_type_constraint($type);
+                $TYPE{$type} = _build_type_constraint($type);
             } else {
                 Carp::croak "Could not find the type constraint ($type) to coerce from"
             }
@@ -168,18 +183,20 @@ sub role_type {
     );
 }
 
+# this is an original method for Mouse
 sub typecast_constraints {
-    my($class, $pkg, $type_constraint, $types, $value) = @_;
+    my($class, $pkg, $types, $value) = @_;
+    Carp::croak("wrong arguments count") unless @_==4;
 
     local $_;
-    for my $type (ref($types) eq 'ARRAY' ? @{ $types } : ( $types )) {
+    for my $type ( split /\|/, $types ) {
         next unless $COERCE{$type};
         for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
             $_ = $value;
-            next unless $TYPE{$coerce_type}->($value);
+            next unless $TYPE{$coerce_type}->check($value);
             $_ = $value;
             $_ = $COERCE{$type}->{$coerce_type}->($value);
-            return $_ if $type_constraint->($_);
+            return $_ if $types->check($_);
         }
     }
     return $value;
@@ -210,6 +227,7 @@ sub _build_type_constraint {
 
     my $spec = shift;
     my $code;
+    $spec =~ s/\s+//g;
     if ($spec =~ /^([^\[]+)\[(.+)\]$/) {
         # parameterized
         my $constraint = $1;
@@ -225,9 +243,9 @@ sub _build_type_constraint {
             my $code_str = 
                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
                 "sub {\n" .
-                "    if (\$parent->(\$_[0])) {\n" .
+                "    if (\$parent->check(\$_[0])) {\n" .
                 "        foreach my \$e (\@{\$_[0]}) {\n" .
-                "            return () unless \$child->(\$e);\n" .
+                "            return () unless \$child->check(\$e);\n" .
                 "        }\n" .
                 "        return 1;\n" .
                 "    }\n" .
@@ -239,9 +257,9 @@ sub _build_type_constraint {
             my $code_str = 
                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
                 "sub {\n" .
-                "    if (\$parent->(\$_[0])) {\n" .
+                "    if (\$parent->check(\$_[0])) {\n" .
                 "        foreach my \$e (values \%{\$_[0]}) {\n" .
-                "            return () unless \$child->(\$e);\n" .
+                "            return () unless \$child->check(\$e);\n" .
                 "        }\n" .
                 "        return 1;\n" .
                 "    }\n" .
@@ -253,14 +271,14 @@ sub _build_type_constraint {
             my $code_str =
                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
                 "sub {\n" .
-                "    return \$child->(\$_[0]) || \$parent->(\$_[0]);\n" .
+                "    return \$child->check(\$_[0]) || \$parent->check(\$_[0]);\n" .
                 "};\n"
             ;
             $code = eval $code_str or Carp::confess($@);
         } else {
-            Carp::confess("Support for parameterized types other than ArrayRef or HashRef is not implemented yet");
+            Carp::confess("Support for parameterized types other than Maybe, ArrayRef or HashRef is not implemented yet");
         }
-        $TYPE{$spec} = $code;
+        $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
     } else {
         $code = $TYPE{ $spec };
         if (! $code) {
@@ -271,10 +289,10 @@ sub _build_type_constraint {
                 "}"
             ;
             $code = eval $code_str  or Carp::confess($@);
-            $TYPE{$spec} = bless $code, 'Mouse::Meta::TypeConstraint';
+            $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
         }
     }
-    return bless $code, 'Mouse::Meta::TypeConstraint';
+    return Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
 }
 
 sub find_type_constraint {
@@ -288,33 +306,32 @@ sub find_or_create_isa_type_constraint {
     my $code;
 
     $type_constraint =~ s/\s+//g;
-    my @type_constraints = split /\|/, $type_constraint;
-    if (@type_constraints == 1) {
-        $code = $TYPE{$type_constraints[0]} ||
-            _build_type_constraint($type_constraints[0]);
-    } else {
-        my @code_list = map {
-            $TYPE{$_} || _build_type_constraint($_)
-        } @type_constraints;
-        $code = bless sub {
-            my $i = 0;
-            for my $code (@code_list) {
-                return 1 if $code->($_[0]);
-            }
-            return 0;
-        }, 'Mouse::Meta::TypeConstraint';
+
+    $code = $TYPE{$type_constraint};
+    if (! $code) {
+        my @type_constraints = split /\|/, $type_constraint;
+        if (@type_constraints == 1) {
+            $code = $TYPE{$type_constraints[0]} ||
+                _build_type_constraint($type_constraints[0]);
+        } else {
+            my @code_list = map {
+                $TYPE{$_} || _build_type_constraint($_)
+            } @type_constraints;
+            $code = Mouse::Meta::TypeConstraint->new(
+                _compiled_type_constraint => sub {
+                    my $i = 0;
+                    for my $code (@code_list) {
+                        return 1 if $code->check($_[0]);
+                    }
+                    return 0;
+                },
+                name => $type_constraint,
+            );
+        }
     }
     return $code;
 }
 
-package # Hide from pause
-    Mouse::Meta::TypeConstraint;
-
-sub check { 
-    $_[0]->($_[1])
-}
-
-
 1;
 
 __END__