fix references to test files
[gitmo/Moose.git] / lib / Moose / Util / TypeConstraints.pm
index 290a230..375e5f4 100644 (file)
@@ -6,10 +6,6 @@ use List::MoreUtils qw( all any );
 use Scalar::Util qw( blessed reftype );
 use Moose::Exporter;
 
-our $VERSION = '0.95';
-$VERSION = eval $VERSION;
-our $AUTHORITY = 'cpan:STEVAN';
-
 ## --------------------------------------------------------
 # Prototyped subs must be predeclared because we have a
 # circular dependency with Moose::Meta::Attribute et. al.
@@ -25,6 +21,7 @@ sub optimize_as (&);
 
 ## --------------------------------------------------------
 
+use Moose::Deprecated;
 use Moose::Meta::TypeConstraint;
 use Moose::Meta::TypeConstraint::Union;
 use Moose::Meta::TypeConstraint::Parameterized;
@@ -275,6 +272,12 @@ sub type {
 
     # back-compat version, called without sugar
     if ( !any { ( reftype($_) || '' ) eq 'HASH' } @_ ) {
+        Moose::Deprecated::deprecated(
+            feature => 'type without sugar',
+            message =>
+                'Calling type() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
+        );
+
         return _create_type_constraint( $_[0], undef, $_[1] );
     }
 
@@ -294,6 +297,12 @@ sub subtype {
     #
     # subtype 'Parent', sub { where };
     if ( scalar @_ == 2 && ( reftype( $_[1] ) || '' ) eq 'CODE' ) {
+        Moose::Deprecated::deprecated(
+            feature => 'subtype without sugar',
+            message =>
+                'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
+        );
+
         return _create_type_constraint( undef, @_ );
     }
 
@@ -301,11 +310,23 @@ sub subtype {
     # subtype 'Parent', sub { where }, sub { message }, sub { optimized };
     if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' }
         @_[ 1 .. $#_ ] ) {
+        Moose::Deprecated::deprecated(
+            feature => 'subtype without sugar',
+            message =>
+                'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
+        );
+
         return _create_type_constraint( undef, @_ );
     }
 
     # subtype 'Name', 'Parent', ...
     if ( scalar @_ >= 2 && all { !ref } @_[ 0, 1 ] ) {
+        Moose::Deprecated::deprecated(
+            feature => 'subtype without sugar',
+            message =>
+                'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
+        );
+
         return _create_type_constraint(@_);
     }
 
@@ -410,17 +431,16 @@ sub enum {
     # if only an array-ref is passed then
     # you get an anon-enum
     # - SL
-    if ( ref $type_name eq 'ARRAY' && !@values ) {
+    if ( ref $type_name eq 'ARRAY' ) {
+        @values == 0
+            || __PACKAGE__->_throw_error("enum called with an array reference and additional arguments. Did you mean to parenthesize the enum call's parameters?");
+
         @values    = @$type_name;
         $type_name = undef;
     }
     if ( @values == 1 && ref $values[0] eq 'ARRAY' ) {
         @values = @{ $values[0] };
     }
-    ( scalar @values >= 2 )
-        || __PACKAGE__->_throw_error(
-        "You must have at least two values to enumerate through");
-    my %valid = map { $_ => 1 } @values;
 
     register_type_constraint(
         create_enum_type_constraint(
@@ -573,20 +593,53 @@ sub _install_type_coercions ($$) {
 
     my $valid_chars = qr{[\w:\.]};
     my $type_atom   = qr{ (?>$valid_chars+) }x;
-    my $ws   = qr{ (?>\s*) }x;
-
-    my $any;
-
-    my $type = qr{  $type_atom  (?: \[ $ws (??{$any})   $ws \] )? }x;
-    my $type_capture_parts
-        = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x;
-    my $type_with_parameter
-        = qr{  $type_atom      \[ $ws (??{$any})   $ws \]    }x;
-
-    my $op_union = qr{ $ws \| $ws }x;
-    my $union    = qr{ $type (?> (?: $op_union $type )+ ) }x;
+    my $ws          = qr{ (?>\s*) }x;
+    my $op_union    = qr{ $ws \| $ws }x;
+
+    my ($type, $type_capture_parts, $type_with_parameter, $union, $any);
+    if (Class::MOP::IS_RUNNING_ON_5_10) {
+        my $type_pattern
+            = q{  (?&type_atom)  (?: \[ (?&ws)  (?&any)  (?&ws) \] )? };
+        my $type_capture_parts_pattern
+            = q{ ((?&type_atom)) (?: \[ (?&ws) ((?&any)) (?&ws) \] )? };
+        my $type_with_parameter_pattern
+            = q{  (?&type_atom)      \[ (?&ws)  (?&any)  (?&ws) \]    };
+        my $union_pattern
+            = q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) };
+        my $any_pattern
+            = q{ (?&type) | (?&union) };
+
+        my $defines = qr{(?(DEFINE)
+            (?<valid_chars>         $valid_chars)
+            (?<type_atom>           $type_atom)
+            (?<ws>                  $ws)
+            (?<op_union>            $op_union)
+            (?<type>                $type_pattern)
+            (?<type_capture_parts>  $type_capture_parts_pattern)
+            (?<type_with_parameter> $type_with_parameter_pattern)
+            (?<union>               $union_pattern)
+            (?<any>                 $any_pattern)
+        )}x;
+
+        $type                = qr{ $type_pattern                $defines }x;
+        $type_capture_parts  = qr{ $type_capture_parts_pattern  $defines }x;
+        $type_with_parameter = qr{ $type_with_parameter_pattern $defines }x;
+        $union               = qr{ $union_pattern               $defines }x;
+        $any                 = qr{ $any_pattern                 $defines }x;
+    }
+    else {
+        $type
+            = qr{  $type_atom  (?: \[ $ws  (??{$any})  $ws \] )? }x;
+        $type_capture_parts
+            = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x;
+        $type_with_parameter
+            = qr{  $type_atom      \[ $ws  (??{$any})  $ws \]    }x;
+        $union
+            = qr{ $type (?> (?: $op_union $type )+ ) }x;
+        $any
+            = qr{ $type | $union }x;
+    }
 
-    $any = qr{ $type | $union }x;
 
     sub _parse_parameterized_type_constraint {
         { no warnings 'void'; $any; }  # force capture of interpolated lexical
@@ -672,14 +725,11 @@ subtype 'Num' => as 'Str' =>
 subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ } =>
     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
 
-subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } =>
-    optimize_as
-    \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef;
 subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } =>
     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
-subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } =>
-    optimize_as
-    \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
+subtype 'RegexpRef' => as 'Ref' =>
+    where(\&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef) =>
+    optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
 subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } =>
     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
 
@@ -691,10 +741,8 @@ subtype 'FileHandle' => as 'GlobRef' => where {
 } => optimize_as
     \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
 
-# NOTE:
-# blessed(qr/.../) returns true,.. how odd
 subtype 'Object' => as 'Ref' =>
-    where { blessed($_) && blessed($_) ne 'Regexp' } =>
+    where { blessed($_) } =>
     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
 
 # This type is deprecated.
@@ -717,6 +765,24 @@ subtype 'RoleName' => as 'ClassName' => where {
 
 $REGISTRY->add_type_constraint(
     Moose::Meta::TypeConstraint::Parameterizable->new(
+        name               => 'ScalarRef',
+        package_defined_in => __PACKAGE__,
+        parent             => find_type_constraint('Ref'),
+        constraint         => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' },
+        optimized =>
+            \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef,
+        constraint_generator => sub {
+            my $type_parameter = shift;
+            my $check          = $type_parameter->_compiled_type_constraint;
+            return sub {
+                return $check->(${ $_ });
+            };
+        }
+    )
+);
+
+$REGISTRY->add_type_constraint(
+    Moose::Meta::TypeConstraint::Parameterizable->new(
         name               => 'ArrayRef',
         package_defined_in => __PACKAGE__,
         parent             => find_type_constraint('Ref'),
@@ -775,7 +841,7 @@ $REGISTRY->add_type_constraint(
 );
 
 my @PARAMETERIZABLE_TYPES
-    = map { $REGISTRY->get_type_constraint($_) } qw[ArrayRef HashRef Maybe];
+    = map { $REGISTRY->get_type_constraint($_) } qw[ScalarRef ArrayRef HashRef Maybe];
 
 sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES}
 
@@ -807,32 +873,30 @@ sub _throw_error {
 
 1;
 
+# ABSTRACT: Type constraint system for Moose
+
 __END__
 
 =pod
 
-=head1 NAME
-
-Moose::Util::TypeConstraints - Type constraint system for Moose
-
 =head1 SYNOPSIS
 
   use Moose::Util::TypeConstraints;
 
-  subtype 'Natural'
-      => as 'Int'
-      => where { $_ > 0 };
+  subtype 'Natural',
+      as 'Int',
+      where { $_ > 0 };
 
-  subtype 'NaturalLessThanTen'
-      => as 'Natural'
-      => where { $_ < 10 }
-      => message { "This number ($_) is not less than ten!" };
+  subtype 'NaturalLessThanTen',
+      as 'Natural',
+      where { $_ < 10 },
+      message { "This number ($_) is not less than ten!" };
 
-  coerce 'Num'
-      => from 'Str'
-        => via { 0+$_ };
+  coerce 'Num',
+      from 'Str',
+      via { 0+$_ };
 
-  enum 'RGBColors' => qw(red green blue);
+  enum 'RGBColors', [qw(red green blue)];
 
   no Moose::Util::TypeConstraints;
 
@@ -874,7 +938,7 @@ 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') };
+  subtype 'DateTime', as 'Object', where { $_->isa('DateTime') };
 
 =head2 Default Type Constraints
 
@@ -894,7 +958,7 @@ that hierarchy represented visually.
                   ClassName
                   RoleName
           Ref
-              ScalarRef
+              ScalarRef[`a]
               ArrayRef[`a]
               HashRef[`a]
               CodeRef
@@ -908,6 +972,7 @@ parameterized, this means you can say:
 
   ArrayRef[Int]    # an array of integers
   HashRef[CodeRef] # a hash of str to CODE ref mappings
+  ScalarRef[Int]   # a reference to an integer
   Maybe[Str]       # value may be a string, may be undefined
 
 If Moose finds a name in brackets that it does not recognize as an
@@ -952,21 +1017,21 @@ 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)
-      )
-  };
-
-For more examples see the F<t/200_examples/004_example_w_DCS.t> test
+      where {
+          IsHashRef(
+              -keys   => HasLength,
+              -values => IsArrayRef(IsObject)
+          )->(@_);
+      };
+
+For more examples see the F<t/examples/example_w_DCS.t> test
 file.
 
 Here is an example of using L<Test::Deep> and it's non-test
 related C<eq_deeply> function.
 
-  type 'ArrayOfHashOfBarsAndRandomNumbers'
-      => where {
+  type 'ArrayOfHashOfBarsAndRandomNumbers',
+      where {
           eq_deeply($_,
               array_each(subhashof({
                   bar           => isa('Bar'),
@@ -975,7 +1040,23 @@ related C<eq_deeply> function.
         };
 
 For a complete example see the
-F<t/200_examples/005_example_w_TestDeep.t> test file.
+F<t/examples/example_w_TestDeep.t> test file.
+
+=head2 Error messages
+
+Type constraints can also specify custom error messages, for when they fail to
+validate. This is provided as just another coderef, which receives the invalid
+value in C<$_>, as in:
+
+  subtype 'PositiveInt',
+       as 'Int',
+       where { $_ > 0 },
+       message { "$_ is not a positive integer!" };
+
+If no message is specified, a default message will be used, which indicates
+which type constraint was being used and what value failed. If
+L<Devel::PartialDump> (version 0.14 or higher) is installed, it will be used to
+display the invalid value, otherwise it will just be printed as is.
 
 =head1 FUNCTIONS
 
@@ -985,11 +1066,11 @@ The following functions are used to create type constraints.  They
 will also register the type constraints your create in a global
 registry that is used to look types up by name.
 
-See the L<SYNOPSIS> for an example of how to use these.
+See the L</SYNOPSIS> for an example of how to use these.
 
 =over 4
 
-=item B<< subtype 'Name' => as 'Parent' => where { } ... >>
+=item B<< subtype 'Name', as 'Parent', where { } ... >>
 
 This creates a named subtype.
 
@@ -1005,7 +1086,7 @@ name and a hashref of parameters:
 The valid hashref keys are C<as> (the parent), C<where>, C<message>,
 and C<optimize_as>.
 
-=item B<< subtype as 'Parent' => where { } ... >>
+=item B<< subtype as 'Parent', where { } ... >>
 
 This creates an unnamed subtype and will return the type
 constraint meta-object, which will be an instance of
@@ -1057,7 +1138,7 @@ This can be used in an attribute definition like so:
 This will create a basic subtype for a given set of strings.
 The resulting constraint will be a subtype of C<Str> and
 will match any of the items in C<\@values>. It is case sensitive.
-See the L<SYNOPSIS> for a simple example.
+See the L</SYNOPSIS> for a simple example.
 
 B<NOTE:> This is not a true proper enum type, it is simply
 a convenient constraint builder.
@@ -1103,11 +1184,11 @@ This can be used to define a "hand optimized" version of your
 type constraint which can be used to avoid traversing a subtype
 constraint hierarchy.
 
-B<NOTE:> You should only use this if you know what you are doing,
-all the built in types use this, so your subtypes (assuming they
+B<NOTE:> You should only use this if you know what you are doing.
+All the built in types use this, so your subtypes (assuming they
 are shallow) will not likely need to use this.
 
-=item B<< type 'Name' => where { } ... >>
+=item B<< type 'Name', where { } ... >>
 
 This creates a base type, which has no parent.
 
@@ -1128,7 +1209,7 @@ The valid hashref keys are C<where>, C<message>, and C<optimize_as>.
 =item B<< match_on_type $value => ( $type => \&action, ... ?\&default ) >>
 
 This is a utility function for doing simple type based dispatching similar to
-match/case in O'Caml and case/of in Haskell. It is not as featureful as those
+match/case in OCaml and case/of in Haskell. It is not as featureful as those
 languages, nor does not it support any kind of automatic destructuring
 bind. Here is a simple Perl pretty printer dispatching over the core Moose
 types.
@@ -1202,15 +1283,21 @@ the type-coercion code first, followed by the type constraint
 check. This feature should be used carefully as it is very powerful
 and could easily take off a limb if you are not careful.
 
-See the L<SYNOPSIS> for an example of how to use these.
+See the L</SYNOPSIS> for an example of how to use these.
 
 =over 4
 
-=item B<< coerce 'Name' => from 'OtherName' => via { ... } >>
+=item B<< coerce 'Name', from 'OtherName', via { ... }  >>
 
 This defines a coercion from one type to another. The C<Name> argument
 is the type you are coercing I<to>.
 
+To define multiple coercions, supply more sets of from/via pairs:
+
+  coerce 'Name',
+    from 'OtherName', via { ... },
+    from 'ThirdName', via { ... };
+
 =item B<from 'OtherName'>
 
 This is just sugar for the type coercion construction syntax.
@@ -1314,7 +1401,7 @@ global registry.
 =item B<find_or_create_does_type_constraint($type_name)>
 
 These functions will first call C<find_or_parse_type_constraint>. If
-that function does not return a type, a new anonymous type object will
+that function does not return a type, a new type object will
 be created.
 
 The C<isa> variant will use C<create_class_type_constraint> and the
@@ -1358,17 +1445,4 @@ Adds C<$type> to the list of parameterizable types
 
 See L<Moose/BUGS> for details on reporting bugs.
 
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006-2010 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
 =cut