types

[gitmo/Moose.git] / lib / Moose / Util / TypeConstraints.pm

diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index 0a0df2a..d987f0e 100644 (file)
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -7,36 +7,51 @@ use warnings;
 use Carp         'confess';
 use Scalar::Util 'blessed';
 
-our $VERSION = '0.03';
+our $VERSION = '0.05';
 
 use Moose::Meta::TypeConstraint;
 use Moose::Meta::TypeCoercion;
 
-sub import {
-       shift;
-       my $pkg = shift || caller();
-       return if $pkg eq '-no-export';
-       no strict 'refs';
-       foreach my $export (qw(type subtype as where coerce from via find_type_constraint)) {
-               *{"${pkg}::${export}"} = \&{"${export}"};
-       }       
+{
+    require Sub::Exporter;
+    
+    my @exports = qw[type subtype as where message coerce from via find_type_constraint];
+
+    Sub::Exporter->import( 
+        -setup => { 
+            exports => \@exports,
+            groups  => {
+                default => [':all']
+            }
+        }
+    );
 }
 
 {
     my %TYPES;
-    sub find_type_constraint { $TYPES{$_[0]}->[1] }
-
+    sub find_type_constraint { 
+        return $TYPES{$_[0]}->[1] 
+            if exists $TYPES{$_[0]};
+        return;
+    }
+    
+    sub _dump_type_constraints {
+        require Data::Dumper;        
+        Data::Dumper::Dumper(\%TYPES);
+    }
+    
     sub _create_type_constraint { 
-        my ($name, $parent, $check) = @_;
+        my ($name, $parent, $check, $message) = @_;
         my $pkg_defined_in = scalar(caller(1));
         ($TYPES{$name}->[0] eq $pkg_defined_in)
-            || confess "The type constraint '$name' has already been created"
+            || confess "The type constraint '$name' has already been created "
                  if defined $name && exists $TYPES{$name};                
         $parent = find_type_constraint($parent) if defined $parent;
         my $constraint = Moose::Meta::TypeConstraint->new(
             name       => $name || '__ANON__',
             parent     => $parent,            
-            constraint => $check,           
+            constraint => $check,       
+            message    => $message,    
         );
         $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name;
         return $constraint;
@@ -70,8 +85,8 @@ sub type ($$) {
        _create_type_constraint($name, undef, $check);
 }
 
-sub subtype ($$;$) {
-       unshift @_ => undef if scalar @_ == 2;
+sub subtype ($$;$$) {
+       unshift @_ => undef if scalar @_ <= 2;
        _create_type_constraint(@_);
 }
 
@@ -80,24 +95,35 @@ sub coerce ($@) {
     _install_type_coercions($type_name, \@coercion_map);
 }
 
-sub as    ($) { $_[0] }
-sub from  ($) { $_[0] }
-sub where (&) { $_[0] }
-sub via   (&) { $_[0] }
+sub as      ($) { $_[0] }
+sub from    ($) { $_[0] }
+sub where   (&) { $_[0] }
+sub via     (&) { $_[0] }
+sub message (&) { $_[0] }
 
 # define some basic types
 
-type 'Any' => where { 1 };
+type 'Any'  => where { 1 }; # meta-type including all
+type 'Item' => where { 1 }; # base-type 
+
+subtype 'Undef'   => as 'Item' => where { !defined($_) };
+subtype 'Defined' => as 'Item' => where {  defined($_) };
+
+subtype 'Value' => as 'Item' => where { !ref($_) };
+subtype 'Ref'   => as 'Item' => where {  ref($_) };
 
-type 'Value' => where { !ref($_) };
-type 'Ref'   => where {  ref($_) };
+subtype 'Bool'  => as 'Item' => where { "$_" eq '1' || "$_" eq '0' };
 
 subtype 'Int' => as 'Value' => where {  Scalar::Util::looks_like_number($_) };
 subtype 'Str' => as 'Value' => where { !Scalar::Util::looks_like_number($_) };
 
 subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' };      
-subtype 'ArrayRef'  => as 'Ref' => where { ref($_) eq 'ARRAY'  };
-subtype 'HashRef'   => as 'Ref' => where { ref($_) eq 'HASH'   };      
+
+subtype 'CollectionRef' => as 'Ref' => where { ref($_) eq 'ARRAY' || ref($_) eq 'HASH' };
+
+subtype 'ArrayRef' => as 'CollectionRef' => where { ref($_) eq 'ARRAY'  };
+subtype 'HashRef'  => as 'CollectionRef' => where { ref($_) eq 'HASH'   };     
+
 subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   };
 subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' };      
 
@@ -105,6 +131,8 @@ subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' };
 # blessed(qr/.../) returns true,.. how odd
 subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' };
 
+subtype 'Role' => as 'Object' => where { $_->can('does') };
+
 1;
 
 __END__
@@ -127,7 +155,8 @@ Moose::Util::TypeConstraints - Type constraint system for Moose
   
   subtype NaturalLessThanTen 
       => as Natural
-      => where { $_ < 10 };
+      => where { $_ < 10 }
+      => message { "This number ($_) is not less than ten!" };
       
   coerce Num 
       => from Str
@@ -154,16 +183,23 @@ This module also provides a simple hierarchy for Perl 5 types, this
 could probably use some work, but it works for me at the moment.
 
   Any
+  
+  Item 
+      Undef
+      Defined
+      Bool
       Value
           Int
           Str
       Ref
           ScalarRef
-          ArrayRef
-          HashRef
+          CollectionRef
+              ArrayRef
+              HashRef
           CodeRef
           RegexpRef
           Object       
+              Role
 
 Suggestions for improvement are welcome.
     
@@ -200,11 +236,11 @@ See the L<SYNOPOSIS> for an example of how to use these.
 
 This creates a base type, which has no parent. 
 
-=item B<subtype ($name, $parent, $where_clause)>
+=item B<subtype ($name, $parent, $where_clause, ?$message)>
 
 This creates a named subtype. 
 
-=item B<subtype ($parent, $where_clause)>
+=item B<subtype ($parent, $where_clause, ?$message)>
 
 This creates an unnamed subtype and will return the type 
 constraint meta-object, which will be an instance of 
@@ -218,6 +254,10 @@ This is just sugar for the type constraint construction syntax.
 
 This is just sugar for the type constraint construction syntax.
 
+=item B<message>
+
+This is just sugar for the type constraint construction syntax.
+
 =back
 
 =head2 Type Coercion Constructors