X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FUtil%2FTypeConstraints.pm;h=54246b863a3fd0b985fd38b8187e3bde4d28c9d8;hp=8df17ea46e9ca4336ecb5bd4039a067902c5870c;hb=f3bb863f6a6ef09220bbf51bc4cea3874d862776;hpb=cd2b92018095c8d3bc88f46cef5f5a0a11e0bf3b

diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm
index 8df17ea..54246b8 100644
--- a/lib/Mouse/Util/TypeConstraints.pm
+++ b/lib/Mouse/Util/TypeConstraints.pm
@@ -1,12 +1,17 @@
 package Mouse::Util::TypeConstraints;
 use strict;
 use warnings;
-use base 'Exporter';
+
+use Exporter;
 
 use Carp ();
 use Scalar::Util qw/blessed looks_like_number openhandle/;
+
+use Mouse::Util qw(does_role not_supported);
+use Mouse::Meta::Module; # class_of
 use Mouse::Meta::TypeConstraint;
 
+our @ISA    = qw(Exporter);
 our @EXPORT = qw(
     as where message from via type subtype coerce class_type role_type enum
     find_type_constraint
@@ -27,24 +32,21 @@ sub message (&) {
     return(message => $_[0])
 }
 
-sub from { @_ }
+sub from    { @_ }
 sub via (&) { $_[0] }
 
 BEGIN {
-    no warnings 'uninitialized';
-    %TYPE = (
+    my %builtins = (
         Any        => sub { 1 },
         Item       => sub { 1 },
-        Bool       => sub {
-            !defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0'
-        },
+
+        Bool       => sub { $_[0] ? $_[0] eq '1' : 1 },
         Undef      => sub { !defined($_[0]) },
         Defined    => sub { defined($_[0]) },
         Value      => sub { defined($_[0]) && !ref($_[0]) },
         Num        => sub { !ref($_[0]) && looks_like_number($_[0]) },
         Int        => sub { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ },
         Str        => sub { defined($_[0]) && !ref($_[0]) },
-        ClassName  => sub { Mouse::is_class_loaded($_[0]) },
         Ref        => sub { ref($_[0]) },
 
         ScalarRef  => sub { ref($_[0]) eq 'SCALAR' },
@@ -61,74 +63,124 @@ BEGIN {
         },
 
         Object     => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' },
+
+        ClassName  => sub { Mouse::Util::is_class_loaded($_[0]) },
+        RoleName   => sub { (Mouse::Util::find_meta($_[0]) || return 0)->isa('Mouse::Meta::Role') },
     );
-    while (my ($name, $code) = each %TYPE) {
-        $TYPE{$name} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $name );
+
+    while (my ($name, $code) = each %builtins) {
+        $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
+            name                      => $name,
+            _compiled_type_constraint => $code,
+        );
+        $TYPE_SOURCE{$name} = __PACKAGE__;
     }
 
     sub optimized_constraints { \%TYPE }
-    my @TYPE_KEYS = keys %TYPE;
-    sub list_all_builtin_type_constraints { @TYPE_KEYS }
 
-    @TYPE_SOURCE{@TYPE_KEYS} = (__PACKAGE__) x @TYPE_KEYS;
+    my @builtins = keys %TYPE;
+    sub list_all_builtin_type_constraints { @builtins }
+
+    sub list_all_type_constraints         { keys %TYPE }
 }
 
 sub type {
-    my $pkg = caller(0);
-    my($name, %conf) = @_;
+    my $name;
+    my %conf;
+
+    if(@_ == 1 && ref $_[0]){ # type { where => ... }
+        %conf = %{$_[0]};
+    }
+    elsif(@_ == 2 && ref $_[1]){ # type $name => { where => ... }*
+        $name = $_[0];
+        %conf = %{$_[1]};
+    }
+    elsif(@_ % 2){ # odd number of arguments
+        $name = shift;
+        %conf = @_;
+    }
+    else{
+        %conf = @_;
+    }
+
+    $name = '__ANON__' if !defined $name;
+
+    my $pkg = caller;
 
     if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
         Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
     }
+
     my $constraint = $conf{where} || do {
         my $as = delete $conf{as} || 'Any';
-        if (! exists $TYPE{$as}) {
-            $TYPE{$as} = _build_type_constraint($as);
-        }
-        $TYPE{$as};
+        ($TYPE{$as} ||= _build_type_constraint($as))->{_compiled_type_constraint};
     };
 
-    $TYPE_SOURCE{$name} = $pkg;
-    $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
-        name => $name,
+    my $tc = Mouse::Meta::TypeConstraint->new(
+        name                      => $name,
         _compiled_type_constraint => sub {
             local $_ = $_[0];
-            if (ref $constraint eq 'CODE') {
-                $constraint->($_[0])
-            } else {
-                $constraint->check($_[0])
-            }
-        }
+            return &{$constraint};
+        },
     );
+
+    $TYPE_SOURCE{$name} = $pkg;
+    $TYPE{$name}        = $tc;
+
+    return $tc;
 }
 
 sub subtype {
-    my $pkg = caller(0);
-    my($name, %conf) = @_;
+    my $name;
+    my %conf;
+
+    if(@_ == 1 && ref $_[0]){ # type { where => ... }
+        %conf = %{$_[0]};
+    }
+    elsif(@_ == 2 && ref $_[1]){ # type $name => { where => ... }*
+        $name = $_[0];
+        %conf = %{$_[1]};
+    }
+    elsif(@_ % 2){ # odd number of arguments
+        $name = shift;
+        %conf = @_;
+    }
+    else{
+        %conf = @_;
+    }
+
+    $name = '__ANON__' if !defined $name;
+
+    my $pkg = caller;
+
     if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
         Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
-    };
-    my $constraint = delete $conf{where};
-    my $as_constraint = find_or_create_isa_type_constraint(delete $conf{as} || 'Any');
+    }
 
-    $TYPE_SOURCE{$name} = $pkg;
-    $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
+    my $constraint    = delete $conf{where};
+    my $as_constraint = find_or_create_isa_type_constraint(delete $conf{as} || 'Any')
+        ->{_compiled_type_constraint};
+
+    my $tc = Mouse::Meta::TypeConstraint->new(
         name => $name,
         _compiled_type_constraint => (
             $constraint ? 
             sub {
                 local $_ = $_[0];
-                $as_constraint->check($_[0]) && $constraint->($_[0])
+                $as_constraint->($_[0]) && $constraint->($_[0])
             } :
             sub {
                 local $_ = $_[0];
-                $as_constraint->check($_[0]);
+                $as_constraint->($_[0]);
             }
         ),
-        %conf
+        %conf,
     );
 
-    return $name;
+    $TYPE_SOURCE{$name} = $pkg;
+    $TYPE{$name}        = $tc;
+
+    return $tc;
 }
 
 sub coerce {
@@ -166,10 +218,11 @@ sub class_type {
     if ($conf && $conf->{class}) {
         # No, you're using this wrong
         warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?";
-        subtype($name, as => $conf->{class});
-    } else {
-        subtype(
-            $name => where => sub { $_->isa($name) }
+        subtype $name => (as => $conf->{class});
+    }
+    else {
+        subtype $name => (
+            where => sub { blessed($_) && $_->isa($name) },
         );
     }
 }
@@ -177,18 +230,15 @@ sub class_type {
 sub role_type {
     my($name, $conf) = @_;
     my $role = $conf->{role};
-    subtype(
-        $name => where => sub {
-            return unless defined $_ && ref($_) && $_->isa('Mouse::Object');
-            $_->meta->does_role($role);
-        }
+    subtype $name => (
+        where => sub { does_role($_, $role) },
     );
 }
 
 # this is an original method for Mouse
 sub typecast_constraints {
     my($class, $pkg, $types, $value) = @_;
-    Carp::croak("wrong arguments count") unless @_==4;
+    Carp::croak("wrong arguments count") unless @_ == 4;
 
     local $_;
     for my $type ( split /\|/, $types ) {
@@ -226,18 +276,21 @@ sub enum {
 }
 
 sub _build_type_constraint {
+    my($spec) = @_;
 
-    my $spec = shift;
     my $code;
     $spec =~ s/\s+//g;
-    if ($spec =~ /^([^\[]+)\[(.+)\]$/) {
+
+    if ($spec =~ /\A (\w+) \[ (.+) \] \z/xms) {
         # parameterized
         my $constraint = $1;
         my $param      = $2;
         my $parent;
+
         if ($constraint eq 'Maybe') {
             $parent = _build_type_constraint('Undef');
-        } else {
+        }
+        else {
             $parent = _build_type_constraint($constraint);
         }
         my $child = _build_type_constraint($param);
@@ -302,8 +355,17 @@ sub _build_type_constraint {
 }
 
 sub find_type_constraint {
-    my $type_constraint = shift;
-    return $TYPE{$type_constraint};
+    my($type) = @_;
+    if(blessed($type) && $type->isa('Mouse::Meta::TypeConstraint')){
+        return $type;
+    }
+    else{
+        return $TYPE{$type};
+    }
+}
+
+sub find_or_create_does_type_constraint{
+    not_supported;
 }
 
 sub find_or_create_isa_type_constraint {
@@ -316,33 +378,34 @@ sub find_or_create_isa_type_constraint {
            $1 ne 'Maybe'
     ;
 
-    my $code;
 
     $type_constraint =~ s/\s+//g;
 
-    $code = $TYPE{$type_constraint};
-    if (! $code) {
+    my $tc =  find_type_constraint($type_constraint);
+    if (!$tc) {
         my @type_constraints = split /\|/, $type_constraint;
         if (@type_constraints == 1) {
-            $code = $TYPE{$type_constraints[0]} ||
+            $tc = $TYPE{$type_constraints[0]} ||
                 _build_type_constraint($type_constraints[0]);
-        } else {
+        }
+        else {
             my @code_list = map {
                 $TYPE{$_} || _build_type_constraint($_)
             } @type_constraints;
-            $code = Mouse::Meta::TypeConstraint->new(
+
+            $tc = Mouse::Meta::TypeConstraint->new(
+                name => $type_constraint,
+
                 _compiled_type_constraint => sub {
-                    my $i = 0;
-                    for my $code (@code_list) {
+                    foreach my $code (@code_list) {
                         return 1 if $code->check($_[0]);
                     }
                     return 0;
                 },
-                name => $type_constraint,
             );
         }
     }
-    return $code;
+    return $tc;
 }
 
 1;
@@ -521,21 +584,31 @@ Returns the simple type constraints that Mouse understands.
 
 =over 4
 
-=item B<subtype 'Name' => as 'Parent' => where { } ...>
+=item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >>
+
+=item C<< subtype as 'Parent' => where { } ...  -> Mouse::Meta::TypeConstraint >>
+
+=item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >>
+
+=item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
 
-=item B<subtype as 'Parent' => where { } ...>
+=item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
 
-=item B<class_type ($class, ?$options)>
+=back
 
-=item B<role_type ($role, ?$options)>
+=over 4
 
-=item B<enum (\@values)>
+=item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >>
 
 =back
 
 =head1 THANKS
 
-Much of this documentation was taken from L<Moose::Util::TypeConstraints>
+Much of this documentation was taken from C<Moose::Util::TypeConstraints>
+
+=head1 SEE ALSO
+
+L<Moose::Util::TypeConstraints>
 
 =cut