X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FPurePerl.pm;h=7a41b08cffbbc70c0dee35f5d6f5ed14baf9c562;hp=b2c4b67a5b4b90ffeab5bf673fa399df121a936b;hb=224bfdd88300af5e6aa044b64111c3e0b1e64e94;hpb=e3540312c014bf730083fab1d0af13c002691115

diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index b2c4b67..7a41b08 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -1,5 +1,7 @@
 package Mouse::PurePerl;
 
+require Mouse::Util;
+
 package
     Mouse::Util;
 
@@ -124,6 +126,41 @@ sub Object     { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }
 sub ClassName  { Mouse::Util::is_class_loaded($_[0]) }
 sub RoleName   { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') }
 
+sub _parameterize_ArrayRef_for {
+    my($type_parameter) = @_;
+    my $check = $type_parameter->_compiled_type_constraint;
+
+    return sub {
+        foreach my $value (@{$_}) {
+            return undef unless $check->($value);
+        }
+        return 1;
+    }
+}
+
+sub _parameterize_HashRef_for {
+    my($type_parameter) = @_;
+    my $check = $type_parameter->_compiled_type_constraint;
+
+    return sub {
+        foreach my $value(values %{$_}){
+            return undef unless $check->($value);
+        }
+        return 1;
+    };
+}
+
+# 'Maybe' type accepts 'Any', so it requires parameters
+sub _parameterize_Maybe_for {
+    my($type_parameter) = @_;
+    my $check = $type_parameter->_compiled_type_constraint;
+
+    return sub{
+        return !defined($_) || $check->($_);
+    };
+};
+
+
 
 package
     Mouse::Meta::Module;
@@ -247,6 +284,55 @@ sub _compiled_type_coercion  { $_[0]->{_compiled_type_coercion}  }
 
 sub has_coercion{ exists $_[0]->{_compiled_type_coercion} }
 
+
+sub compile_type_constraint{
+    my($self) = @_;
+
+    # add parents first
+    my @checks;
+    for(my $parent = $self->{parent}; defined $parent; $parent = $parent->{parent}){
+         if($parent->{hand_optimized_type_constraint}){
+            unshift @checks, $parent->{hand_optimized_type_constraint};
+            last; # a hand optimized constraint must include all the parents
+        }
+        elsif($parent->{constraint}){
+            unshift @checks, $parent->{constraint};
+        }
+    }
+
+    # then add child
+    if($self->{constraint}){
+        push @checks, $self->{constraint};
+    }
+
+    if($self->{type_constraints}){ # Union
+        my @types = map{ $_->{compiled_type_constraint} } @{ $self->{type_constraints} };
+        push @checks, sub{
+            foreach my $c(@types){
+                return 1 if $c->($_[0]);
+            }
+            return 0;
+        };
+    }
+
+    if(@checks == 0){
+        $self->{compiled_type_constraint} = \&Mouse::Util::TypeConstraints::Any;
+    }
+    else{
+        $self->{compiled_type_constraint} =  sub{
+            my(@args) = @_;
+            local $_ = $args[0];
+            foreach my $c(@checks){
+                return undef if !$c->(@args);
+            }
+            return 1;
+        };
+    }
+    return;
+}
+
+
+
 1;
 __END__
 
@@ -256,7 +342,7 @@ Mouse::PurePerl - A Mouse guts in pure Perl
 
 =head1 VERSION
 
-This document describes Mouse version 0.40_03
+This document describes Mouse version 0.40_05
 
 =head1 SEE ALSO