it-works

diff --git a/lib/Moose.pm b/lib/Moose.pm
index 6f972bc..a8a9a56 100644 (file)
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -76,11 +76,8 @@ sub import {
                }
                if (exists $options{isa}) {
                    # allow for anon-subtypes here ...
-                   if (reftype($options{isa}) && reftype($options{isa}) eq 'CODE') {
-                               $options{type_constraint} = Moose::Meta::TypeConstraint->new(
-                                   name            => '__ANON__',
-                                   constraint_code => $options{isa}
-                               );
+                   if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
+                               $options{type_constraint} = $options{isa};
                        }
                        else {
                            # otherwise assume it is a constraint
@@ -89,10 +86,7 @@ sub import {
                            unless (defined $constraint) {
                                # assume it is a foreign class, and make 
                                # an anon constraint for it 
-                               $constraint = Moose::Meta::TypeConstraint->new(
-                                   name            => '__ANON__',
-                                   constraint_code => subtype Object => where { $_->isa($constraint) }
-                               );
+                               $constraint = subtype Object => where { $_->isa($options{isa}) };
                            }                       
                 $options{type_constraint} = $constraint;
                        }

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 014dc7b..fcd4e7d 100644 (file)
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -27,7 +27,7 @@ sub construct_instance {
                        $val = $attr->type_constraint->coercion_code->($val);
                    }   
                 (defined($attr->type_constraint->constraint_code->($val))) 
-                    || confess "Attribute (" . $attr->name . ") does not pass the type contraint with";                        
+                    || confess "Attribute (" . $attr->name . ") does not pass the type contraint with '$val'";                 
             }
                }
         $instance->{$attr->name} = $val;

diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm
index 651b1bf..b18e498 100644 (file)
--- a/lib/Moose/Meta/TypeConstraint.pm
+++ b/lib/Moose/Meta/TypeConstraint.pm
@@ -5,27 +5,60 @@ use strict;
 use warnings;
 use metaclass;
 
-Moose::Meta::TypeConstraint->meta->add_attribute(
-    Class::MOP::Attribute->new('name' => (
-        reader => 'name'
-    )) 
-);
-
-Moose::Meta::TypeConstraint->meta->add_attribute(
-    Class::MOP::Attribute->new('constraint_code' => (
-        reader => 'constraint_code'
-    )) 
-);
-
-Moose::Meta::TypeConstraint->meta->add_attribute(
-    Class::MOP::Attribute->new('coercion_code' => (
-        reader    => 'coercion_code',
-        writer    => 'set_coercion_code',        
-        predicate => 'has_coercion'
-    )) 
-);
-
-sub new { return (shift)->meta->new_object(@_)  }
+use Sub::Name 'subname';
+use Carp      'confess';
+
+our $VERSION = '0.01';
+
+my %TYPE_CONSTRAINT_REGISTRY;
+
+__PACKAGE__->meta->add_attribute('name'       => (reader => 'name'      ));
+__PACKAGE__->meta->add_attribute('parent'     => (reader => 'parent'    ));
+__PACKAGE__->meta->add_attribute('constraint' => (reader => 'constraint'));
+
+# private accessor
+__PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
+    accessor => '_compiled_type_constraint'
+));
+
+__PACKAGE__->meta->add_attribute('coercion_code' => (
+    reader    => 'coercion_code',
+    writer    => 'set_coercion_code',        
+    predicate => 'has_coercion'
+));
+
+sub new { 
+    my $class  = shift;
+    my $self = $class->meta->new_object(@_);
+    $self->compile_type_constraint();
+    return $self;
+}
+
+sub compile_type_constraint () {
+    my $self   = shift;
+    my $check  = $self->constraint;
+    (defined $check)
+        || confess "Could not compile type constraint '" . $self->name . "' because no constraint check";
+    my $parent = $self->parent;
+    if (defined $parent) {
+        $parent = $parent->_compiled_type_constraint;
+               $self->_compiled_type_constraint(subname $self->name => sub {                   
+                       local $_ = $_[0];
+                       return undef unless defined $parent->($_[0]) && $check->($_[0]);
+                       $_[0];
+               });        
+    }
+    else {
+       $self->_compiled_type_constraint(subname $self->name => sub { 
+               local $_ = $_[0];
+               return undef unless $check->($_[0]);
+               $_[0];
+       });
+    }
+}
+
+# backwards for now
+sub constraint_code { (shift)->_compiled_type_constraint }
 
 1;
 
@@ -51,8 +84,12 @@ Moose::Meta::TypeConstraint - The Moose Type Constraint metaobject
 
 =item B<name>
 
+=item B<parent>
+
 =item B<check>
 
+=item B<constraint>
+
 =item B<coerce>
 
 =item B<coercion_code>
@@ -63,6 +100,8 @@ Moose::Meta::TypeConstraint - The Moose Type Constraint metaobject
 
 =item B<has_coercion>
 
+=item B<compile_type_constraint>
+
 =back
 
 =head1 BUGS

diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index e32da46..cf99b1d 100644 (file)
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -30,22 +30,16 @@ sub import {
     }
 
     sub register_type_constraint { 
-        my ($type_name, $type_constraint) = @_;
-        (not exists $TYPES{$type_name})
-            || confess "The type constraint '$type_name' has already been registered";
-        $TYPES{$type_name} = Moose::Meta::TypeConstraint->new(
-            name            => $type_name,
-            constraint_code => $type_constraint
+        my ($name, $parent, $constraint) = @_;
+        (not exists $TYPES{$name})
+            || confess "The type constraint '$name' has already been registered";
+        $parent = find_type_constraint($parent) if defined $parent;
+        $TYPES{$name} = Moose::Meta::TypeConstraint->new(
+            name       => $name,
+            parent     => $parent,            
+            constraint => $constraint,           
         );
     }
-    
-    sub export_type_contstraints_as_functions {
-        my $pkg = caller();
-           no strict 'refs';
-       foreach my $constraint (keys %TYPES) {
-               *{"${pkg}::${constraint}"} = $TYPES{$constraint}->constraint_code;
-       }        
-    }
 
     sub find_type_coercion { 
         my $type_name = shift;
@@ -59,47 +53,40 @@ sub import {
             || confess "The type coercion for '$type_name' has already been registered";        
         $type->set_coercion_code($type_coercion);
     }
+    
+    sub export_type_contstraints_as_functions {
+        my $pkg = caller();
+           no strict 'refs';
+       foreach my $constraint (keys %TYPES) {
+               *{"${pkg}::${constraint}"} = $TYPES{$constraint}->constraint_code;
+       }        
+    }    
 }
 
 
 sub type ($$) {
        my ($name, $check) = @_;
-       my $full_name = caller() . "::${name}";
-       register_type_constraint($name => subname $full_name => sub { 
-               local $_ = $_[0];
-               return undef unless $check->($_[0]);
-               $_[0];
-       });
+       register_type_constraint($name, undef, $check);
 }
 
 sub subtype ($$;$) {
-       my ($name, $parent, $check) = @_;
-       if (defined $check) {
-           my $full_name = caller() . "::${name}";
-               $parent = find_type_constraint($parent)->constraint_code 
-                   unless $parent && ref($parent) eq 'CODE';
-               register_type_constraint($name => subname $full_name => sub {                   
-                       local $_ = $_[0];
-                       return undef unless defined $parent->($_[0]) && $check->($_[0]);
-                       $_[0];
-               });     
+       if (scalar @_ == 3) {
+           my ($name, $parent, $check) = @_;
+               register_type_constraint($name, $parent, $check);       
        }
        else {
-               ($parent, $check) = ($name, $parent);
-               $parent = find_type_constraint($parent)->constraint_code 
-                   unless $parent && ref($parent) eq 'CODE';           
-               return subname '__anon_subtype__' => sub {                      
-                       local $_ = $_[0];
-                       return undef unless defined $parent->($_[0]) && $check->($_[0]);
-                       $_[0];
-               };              
+               my ($parent, $check) = @_;
+               $parent = find_type_constraint($parent);
+        return Moose::Meta::TypeConstraint->new(
+            name       => '__ANON__',
+            parent     => $parent,
+            constraint => $check,
+        );
        }
 }
 
 sub coerce ($@) {
-    my ($type_name, @coercion_map) = @_;
-    #use Data::Dumper;
-    #warn Dumper \@coercion_map;    
+    my ($type_name, @coercion_map) = @_;   
     my @coercions;
     while (@coercion_map) {
         my ($constraint_name, $action) = splice(@coercion_map, 0, 2);

diff --git a/t/050_util_type_constraints.t b/t/050_util_type_constraints.t
index 5f41558..e0ce780 100644 (file)
--- a/t/050_util_type_constraints.t
+++ b/t/050_util_type_constraints.t
@@ -44,8 +44,8 @@ is(NaturalLessThanTen('Foo'), undef, '... this is not a NaturalLessThanTen');
        
 my $negative = subtype Num => where    { $_ < 0 };
 ok(defined $negative, '... got a value back from negative');
-is(ref($negative), 'CODE', '... got a type constraint back from negative');
+isa_ok($negative, 'Moose::Meta::TypeConstraint');
 
-is($negative->(-5), -5, '... this is a negative number');
-ok(!defined($negative->(5)), '... this is not a negative number');
-is($negative->('Foo'), undef, '... this is not a negative number');    
+is($negative->_compiled_type_constraint->(-5), -5, '... this is a negative number');
+ok(!defined($negative->_compiled_type_constraint->(5)), '... this is not a negative number');
+is($negative->_compiled_type_constraint->('Foo'), undef, '... this is not a negative number');