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=4379903afb7fbb466357e8b07cb59e4145270315;hb=f3bb863f6a6ef09220bbf51bc4cea3874d862776;hpb=78b138270e9ef4dd99b8db615e58fcfd2500f58d

diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm
index 4379903..54246b8 100644
--- a/lib/Mouse/Util/TypeConstraints.pm
+++ b/lib/Mouse/Util/TypeConstraints.pm
@@ -1,13 +1,20 @@
 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
 );
 
 my %TYPE;
@@ -16,35 +23,30 @@ my %COERCE;
 my %COERCE_KEYS;
 
 sub as ($) {
-    as => $_[0]
+    return(as => $_[0]);
 }
 sub where (&) {
-    where => $_[0]
+    return(where => $_[0])
 }
 sub message (&) {
-    message => $_[0]
+    return(message => $_[0])
 }
 
-sub from { @_ }
-sub via (&) {
-    $_[0]
-}
+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,62 +63,128 @@ 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') },
     );
-    foreach my $code (values %TYPE) {
-        bless $code, 'Mouse::Meta::TypeConstraint';
+
+    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};
     };
 
+    my $tc = Mouse::Meta::TypeConstraint->new(
+        name                      => $name,
+        _compiled_type_constraint => sub {
+            local $_ = $_[0];
+            return &{$constraint};
+        },
+    );
+
     $TYPE_SOURCE{$name} = $pkg;
-    $TYPE{$name} = sub { local $_ = $_[0]; $constraint->($_[0]) };
+    $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 = $conf{where};
-    my $as_constraint = find_or_create_isa_type_constraint($conf{as} || 'Any');
+    }
+
+    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->($_[0]) && $constraint->($_[0])
+            } :
+            sub {
+                local $_ = $_[0];
+                $as_constraint->($_[0]);
+            }
+        ),
+        %conf,
+    );
 
     $TYPE_SOURCE{$name} = $pkg;
-    $TYPE{$name} = $constraint ? 
-        sub {
-            local $_ = $_[0];
-            $as_constraint->($_[0]) && $constraint->($_[0])
-        } :
-        sub {
-            local $_ = $_[0];
-            $as_constraint->($_[0]);
-        }
-    ;
+    $TYPE{$name}        = $tc;
 
-    return $name;
+    return $tc;
 }
 
 sub coerce {
-    my($name, %conf) = @_;
+    my $name = shift;
 
     Carp::croak "Cannot find type '$name', perhaps you forgot to load it."
         unless $TYPE{$name};
@@ -125,14 +193,15 @@ sub coerce {
         $COERCE{$name}      = {};
         $COERCE_KEYS{$name} = [];
     }
-    while (my($type, $code) = each %conf) {
+
+    while (my($type, $code) = splice @_, 0, 2) {
         Carp::croak "A coercion action already exists for '$type'"
             if $COERCE{$name}->{$type};
 
         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"
             }
@@ -141,6 +210,7 @@ sub coerce {
         push @{ $COERCE_KEYS{$name} }, $type;
         $COERCE{$name}->{$type} = $code;
     }
+    return;
 }
 
 sub class_type {
@@ -148,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) },
         );
     }
 }
@@ -159,26 +230,25 @@ 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, $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;
@@ -206,17 +276,21 @@ sub enum {
 }
 
 sub _build_type_constraint {
+    my($spec) = @_;
 
-    my $spec = shift;
     my $code;
-    if ($spec =~ /^([^\[]+)\[(.+)\]$/) {
+    $spec =~ s/\s+//g;
+
+    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);
@@ -224,9 +298,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" .
@@ -238,9 +312,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" .
@@ -252,75 +326,253 @@ 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) {
+            # is $spec a known role?  If so, constrain with 'does' instead of 'isa'
+            require Mouse::Meta::Role;
+            my $check = Mouse::Meta::Role->_metaclass_cache($spec)? 
+                'does' : 'isa';
             my $code_str = 
                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
                 "sub {\n" .
-                "    Scalar::Util::blessed(\$_[0]) && \$_[0]->isa('$spec');\n" .
+                "    Scalar::Util::blessed(\$_[0]) && \$_[0]->$check('$spec');\n" .
                 "}"
             ;
             $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 {
-    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 {
     my $type_constraint = shift;
 
-    my $code;
+    Carp::confess("Got isa => type_constraints, but Mouse does not yet support parameterized types for containers other than ArrayRef and HashRef and Maybe (rt.cpan.org #39795)")
+        if $type_constraint =~ /\A ( [^\[]+ ) \[\.+\] \z/xms &&
+           $1 ne 'ArrayRef' &&
+           $1 ne 'HashRef'  &&
+           $1 ne 'Maybe'
+    ;
 
-    $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';
-    }
-    return $code;
-}
 
-package # Hide from pause
-    Mouse::Meta::TypeConstraint;
+    $type_constraint =~ s/\s+//g;
 
-sub check { 
-    $_[0]->($_[1])
+    my $tc =  find_type_constraint($type_constraint);
+    if (!$tc) {
+        my @type_constraints = split /\|/, $type_constraint;
+        if (@type_constraints == 1) {
+            $tc = $TYPE{$type_constraints[0]} ||
+                _build_type_constraint($type_constraints[0]);
+        }
+        else {
+            my @code_list = map {
+                $TYPE{$_} || _build_type_constraint($_)
+            } @type_constraints;
+
+            $tc = Mouse::Meta::TypeConstraint->new(
+                name => $type_constraint,
+
+                _compiled_type_constraint => sub {
+                    foreach my $code (@code_list) {
+                        return 1 if $code->check($_[0]);
+                    }
+                    return 0;
+                },
+            );
+        }
+    }
+    return $tc;
 }
 
-
 1;
 
 __END__
 
 =head1 NAME
 
-Mouse::Util::TypeConstraints - simple type constraints
+Mouse::Util::TypeConstraints - Type constraint system for Mouse
+
+=head2 SYNOPSIS
+
+  use Mouse::Util::TypeConstraints;
+
+  subtype 'Natural'
+      => as 'Int'
+      => where { $_ > 0 };
+
+  subtype 'NaturalLessThanTen'
+      => as 'Natural'
+      => where { $_ < 10 }
+      => message { "This number ($_) is not less than ten!" };
+
+  coerce 'Num'
+      => from 'Str'
+        => via { 0+$_ };
+
+  enum 'RGBColors' => qw(red green blue);
+
+  no Mouse::Util::TypeConstraints;
+
+=head1 DESCRIPTION
+
+This module provides Mouse with the ability to create custom type
+constraints to be used in attribute definition.
+
+=head2 Important Caveat
+
+This is B<NOT> a type system for Perl 5. These are type constraints,
+and they are not used by Mouse unless you tell it to. No type
+inference is performed, expressions are not typed, etc. etc. etc.
+
+A type constraint is at heart a small "check if a value is valid"
+function. A constraint can be associated with an attribute. This
+simplifies parameter validation, and makes your code clearer to read,
+because you can refer to constraints by name.
+
+=head2 Slightly Less Important Caveat
+
+It is B<always> a good idea to quote your type names.
+
+This prevents Perl from trying to execute the call as an indirect
+object call. This can be an issue when you have a subtype with the
+same name as a valid class.
+
+For instance:
+
+  subtype DateTime => as Object => where { $_->isa('DateTime') };
+
+will I<just work>, while this:
+
+  use DateTime;
+  subtype DateTime => as Object => where { $_->isa('DateTime') };
+
+will fail silently and cause many headaches. The simple way to solve
+this, as well as future proof your subtypes from classes which have
+yet to have been created, is to quote the type name:
+
+  use DateTime;
+  subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
+
+=head2 Default Type Constraints
+
+This module also provides a simple hierarchy for Perl 5 types, here is
+that hierarchy represented visually.
+
+  Any
+  Item
+      Bool
+      Maybe[`a]
+      Undef
+      Defined
+          Value
+              Num
+                Int
+              Str
+                ClassName
+                RoleName
+          Ref
+              ScalarRef
+              ArrayRef[`a]
+              HashRef[`a]
+              CodeRef
+              RegexpRef
+              GlobRef
+                FileHandle
+              Object
+                Role
+
+B<NOTE:> Any type followed by a type parameter C<[`a]> can be
+parameterized, this means you can say:
+
+  ArrayRef[Int]    # an array of integers
+  HashRef[CodeRef] # a hash of str to CODE ref mappings
+  Maybe[Str]       # value may be a string, may be undefined
+
+If Mouse finds a name in brackets that it does not recognize as an
+existing type, it assumes that this is a class name, for example
+C<ArrayRef[DateTime]>.
+
+B<NOTE:> Unless you parameterize a type, then it is invalid to include
+the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
+name, I<not> as a parameterization of C<ArrayRef>.
+
+B<NOTE:> The C<Undef> type constraint for the most part works
+correctly now, but edge cases may still exist, please use it
+sparingly.
+
+B<NOTE:> The C<ClassName> type constraint does a complex package
+existence check. This means that your class B<must> be loaded for this
+type constraint to pass.
+
+B<NOTE:> The C<RoleName> constraint checks a string is a I<package
+name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
+constraint checks that an I<object does> the named role.
+
+=head2 Type Constraint Naming
+
+Type name declared via this module can only contain alphanumeric
+characters, colons (:), and periods (.).
+
+Since the types created by this module are global, it is suggested
+that you namespace your types just as you would namespace your
+modules. So instead of creating a I<Color> type for your
+B<My::Graphics> module, you would call the type
+I<My::Graphics::Types::Color> instead.
+
+=head2 Use with Other Constraint Modules
+
+This module can play nicely with other constraint modules with some
+slight tweaking. The C<where> clause in types is expected to be a
+C<CODE> reference which checks it's first argument and returns a
+boolean. Since most constraint modules work in a similar way, it
+should be simple to adapt them to work with Mouse.
+
+For instance, this is how you could use it with
+L<Declare::Constraints::Simple> to declare a completely new type.
+
+  type 'HashOfArrayOfObjects',
+      {
+      where => IsHashRef(
+          -keys   => HasLength,
+          -values => IsArrayRef(IsObject)
+      )
+  };
+
+Here is an example of using L<Test::Deep> and it's non-test
+related C<eq_deeply> function.
+
+  type 'ArrayOfHashOfBarsAndRandomNumbers'
+      => where {
+          eq_deeply($_,
+              array_each(subhashof({
+                  bar           => isa('Bar'),
+                  random_number => ignore()
+              })))
+        };
 
 =head1 METHODS
 
@@ -332,18 +584,32 @@ 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 B<subtype as 'Parent' => where { } ...>
+=item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
 
-=item B<class_type ($class, ?$options)>
+=item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
 
-=item B<role_type ($role, ?$options)>
+=back
+
+=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 C<Moose::Util::TypeConstraints>
+
+=head1 SEE ALSO
+
+L<Moose::Util::TypeConstraints>
+
 =cut