docs about type constraint error messages
[gitmo/Moose.git] / lib / Moose / Util / TypeConstraints.pm
1
2 package Moose::Util::TypeConstraints;
3
4 use Carp ();
5 use List::MoreUtils qw( all any );
6 use Scalar::Util qw( blessed reftype );
7 use Moose::Exporter;
8
9 ## --------------------------------------------------------
10 # Prototyped subs must be predeclared because we have a
11 # circular dependency with Moose::Meta::Attribute et. al.
12 # so in case of us being use'd first the predeclaration
13 # ensures the prototypes are in scope when consumers are
14 # compiled.
15
16 # dah sugah!
17 sub where (&);
18 sub via (&);
19 sub message (&);
20 sub optimize_as (&);
21
22 ## --------------------------------------------------------
23
24 use Moose::Deprecated;
25 use Moose::Meta::TypeConstraint;
26 use Moose::Meta::TypeConstraint::Union;
27 use Moose::Meta::TypeConstraint::Parameterized;
28 use Moose::Meta::TypeConstraint::Parameterizable;
29 use Moose::Meta::TypeConstraint::Class;
30 use Moose::Meta::TypeConstraint::Role;
31 use Moose::Meta::TypeConstraint::Enum;
32 use Moose::Meta::TypeConstraint::DuckType;
33 use Moose::Meta::TypeCoercion;
34 use Moose::Meta::TypeCoercion::Union;
35 use Moose::Meta::TypeConstraint::Registry;
36 use Moose::Util::TypeConstraints::OptimizedConstraints;
37
38 Moose::Exporter->setup_import_methods(
39     as_is => [
40         qw(
41             type subtype class_type role_type maybe_type duck_type
42             as where message optimize_as
43             coerce from via
44             enum
45             find_type_constraint
46             register_type_constraint
47             match_on_type )
48     ],
49 );
50
51 ## --------------------------------------------------------
52 ## type registry and some useful functions for it
53 ## --------------------------------------------------------
54
55 my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new;
56
57 sub get_type_constraint_registry {$REGISTRY}
58 sub list_all_type_constraints    { keys %{ $REGISTRY->type_constraints } }
59
60 sub export_type_constraints_as_functions {
61     my $pkg = caller();
62     no strict 'refs';
63     foreach my $constraint ( keys %{ $REGISTRY->type_constraints } ) {
64         my $tc = $REGISTRY->get_type_constraint($constraint)
65             ->_compiled_type_constraint;
66         *{"${pkg}::${constraint}"}
67             = sub { $tc->( $_[0] ) ? 1 : undef };    # the undef is for compat
68     }
69 }
70
71 sub create_type_constraint_union {
72     my @type_constraint_names;
73
74     if ( scalar @_ == 1 && _detect_type_constraint_union( $_[0] ) ) {
75         @type_constraint_names = _parse_type_constraint_union( $_[0] );
76     }
77     else {
78         @type_constraint_names = @_;
79     }
80
81     ( scalar @type_constraint_names >= 2 )
82         || __PACKAGE__->_throw_error(
83         "You must pass in at least 2 type names to make a union");
84
85     my @type_constraints = map {
86         find_or_parse_type_constraint($_)
87             || __PACKAGE__->_throw_error(
88             "Could not locate type constraint ($_) for the union");
89     } @type_constraint_names;
90
91     return Moose::Meta::TypeConstraint::Union->new(
92         type_constraints => \@type_constraints );
93 }
94
95 sub create_parameterized_type_constraint {
96     my $type_constraint_name = shift;
97     my ( $base_type, $type_parameter )
98         = _parse_parameterized_type_constraint($type_constraint_name);
99
100     ( defined $base_type && defined $type_parameter )
101         || __PACKAGE__->_throw_error(
102         "Could not parse type name ($type_constraint_name) correctly");
103
104     if ( $REGISTRY->has_type_constraint($base_type) ) {
105         my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
106         return _create_parameterized_type_constraint(
107             $base_type_tc,
108             $type_parameter
109         );
110     }
111     else {
112         __PACKAGE__->_throw_error(
113             "Could not locate the base type ($base_type)");
114     }
115 }
116
117 sub _create_parameterized_type_constraint {
118     my ( $base_type_tc, $type_parameter ) = @_;
119     if ( $base_type_tc->can('parameterize') ) {
120         return $base_type_tc->parameterize($type_parameter);
121     }
122     else {
123         return Moose::Meta::TypeConstraint::Parameterized->new(
124             name   => $base_type_tc->name . '[' . $type_parameter . ']',
125             parent => $base_type_tc,
126             type_parameter =>
127                 find_or_create_isa_type_constraint($type_parameter),
128         );
129     }
130 }
131
132 #should we also support optimized checks?
133 sub create_class_type_constraint {
134     my ( $class, $options ) = @_;
135
136 # too early for this check
137 #find_type_constraint("ClassName")->check($class)
138 #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
139
140     my %options = (
141         class => $class,
142         name  => $class,
143         %{ $options || {} },
144     );
145
146     $options{name} ||= "__ANON__";
147
148     Moose::Meta::TypeConstraint::Class->new(%options);
149 }
150
151 sub create_role_type_constraint {
152     my ( $role, $options ) = @_;
153
154 # too early for this check
155 #find_type_constraint("ClassName")->check($class)
156 #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
157
158     my %options = (
159         role => $role,
160         name => $role,
161         %{ $options || {} },
162     );
163
164     $options{name} ||= "__ANON__";
165
166     Moose::Meta::TypeConstraint::Role->new(%options);
167 }
168
169 sub find_or_create_type_constraint {
170     my ( $type_constraint_name, $options_for_anon_type ) = @_;
171
172     if ( my $constraint
173         = find_or_parse_type_constraint($type_constraint_name) ) {
174         return $constraint;
175     }
176     elsif ( defined $options_for_anon_type ) {
177
178         # NOTE:
179         # if there is no $options_for_anon_type
180         # specified, then we assume they don't
181         # want to create one, and return nothing.
182
183         # otherwise assume that we should create
184         # an ANON type with the $options_for_anon_type
185         # options which can be passed in. It should
186         # be noted that these don't get registered
187         # so we need to return it.
188         # - SL
189         return Moose::Meta::TypeConstraint->new(
190             name => '__ANON__',
191             %{$options_for_anon_type}
192         );
193     }
194
195     return;
196 }
197
198 sub find_or_create_isa_type_constraint {
199     my $type_constraint_name = shift;
200     find_or_parse_type_constraint($type_constraint_name)
201         || create_class_type_constraint($type_constraint_name);
202 }
203
204 sub find_or_create_does_type_constraint {
205     my $type_constraint_name = shift;
206     find_or_parse_type_constraint($type_constraint_name)
207         || create_role_type_constraint($type_constraint_name);
208 }
209
210 sub find_or_parse_type_constraint {
211     my $type_constraint_name = normalize_type_constraint_name(shift);
212     my $constraint;
213
214     if ( $constraint = find_type_constraint($type_constraint_name) ) {
215         return $constraint;
216     }
217     elsif ( _detect_type_constraint_union($type_constraint_name) ) {
218         $constraint = create_type_constraint_union($type_constraint_name);
219     }
220     elsif ( _detect_parameterized_type_constraint($type_constraint_name) ) {
221         $constraint
222             = create_parameterized_type_constraint($type_constraint_name);
223     }
224     else {
225         return;
226     }
227
228     $REGISTRY->add_type_constraint($constraint);
229     return $constraint;
230 }
231
232 sub normalize_type_constraint_name {
233     my $type_constraint_name = shift;
234     $type_constraint_name =~ s/\s//g;
235     return $type_constraint_name;
236 }
237
238 sub _confess {
239     my $error = shift;
240
241     local $Carp::CarpLevel = $Carp::CarpLevel + 1;
242     Carp::confess($error);
243 }
244
245 ## --------------------------------------------------------
246 ## exported functions ...
247 ## --------------------------------------------------------
248
249 sub find_type_constraint {
250     my $type = shift;
251
252     if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) {
253         return $type;
254     }
255     else {
256         return unless $REGISTRY->has_type_constraint($type);
257         return $REGISTRY->get_type_constraint($type);
258     }
259 }
260
261 sub register_type_constraint {
262     my $constraint = shift;
263     __PACKAGE__->_throw_error("can't register an unnamed type constraint")
264         unless defined $constraint->name;
265     $REGISTRY->add_type_constraint($constraint);
266     return $constraint;
267 }
268
269 # type constructors
270
271 sub type {
272
273     # back-compat version, called without sugar
274     if ( !any { ( reftype($_) || '' ) eq 'HASH' } @_ ) {
275         Moose::Deprecated::deprecated(
276             feature => 'type without sugar',
277             message =>
278                 'Calling type() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
279         );
280
281         return _create_type_constraint( $_[0], undef, $_[1] );
282     }
283
284     my $name = shift;
285
286     my %p = map { %{$_} } @_;
287
288     return _create_type_constraint(
289         $name, undef, $p{where}, $p{message},
290         $p{optimize_as}
291     );
292 }
293
294 sub subtype {
295
296     # crazy back-compat code for being called without sugar ...
297     #
298     # subtype 'Parent', sub { where };
299     if ( scalar @_ == 2 && ( reftype( $_[1] ) || '' ) eq 'CODE' ) {
300         Moose::Deprecated::deprecated(
301             feature => 'subtype without sugar',
302             message =>
303                 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
304         );
305
306         return _create_type_constraint( undef, @_ );
307     }
308
309     # subtype 'Parent', sub { where }, sub { message };
310     # subtype 'Parent', sub { where }, sub { message }, sub { optimized };
311     if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' }
312         @_[ 1 .. $#_ ] ) {
313         Moose::Deprecated::deprecated(
314             feature => 'subtype without sugar',
315             message =>
316                 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
317         );
318
319         return _create_type_constraint( undef, @_ );
320     }
321
322     # subtype 'Name', 'Parent', ...
323     if ( scalar @_ >= 2 && all { !ref } @_[ 0, 1 ] ) {
324         Moose::Deprecated::deprecated(
325             feature => 'subtype without sugar',
326             message =>
327                 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
328         );
329
330         return _create_type_constraint(@_);
331     }
332
333     if ( @_ == 1 && !ref $_[0] ) {
334         __PACKAGE__->_throw_error(
335             'A subtype cannot consist solely of a name, it must have a parent'
336         );
337     }
338
339     # The blessed check is mostly to accommodate MooseX::Types, which
340     # uses an object which overloads stringification as a type name.
341     my $name = ref $_[0] && !blessed $_[0] ? undef : shift;
342
343     my %p = map { %{$_} } @_;
344
345     # subtype Str => where { ... };
346     if ( !exists $p{as} ) {
347         $p{as} = $name;
348         $name = undef;
349     }
350
351     return _create_type_constraint(
352         $name, $p{as}, $p{where}, $p{message},
353         $p{optimize_as}
354     );
355 }
356
357 sub class_type {
358     register_type_constraint(
359         create_class_type_constraint(
360             $_[0],
361             ( defined( $_[1] ) ? $_[1] : () ),
362         )
363     );
364 }
365
366 sub role_type ($;$) {
367     register_type_constraint(
368         create_role_type_constraint(
369             $_[0],
370             ( defined( $_[1] ) ? $_[1] : () ),
371         )
372     );
373 }
374
375 sub maybe_type {
376     my ($type_parameter) = @_;
377
378     register_type_constraint(
379         $REGISTRY->get_type_constraint('Maybe')->parameterize($type_parameter)
380     );
381 }
382
383 sub duck_type {
384     my ( $type_name, @methods ) = @_;
385     if ( ref $type_name eq 'ARRAY' && !@methods ) {
386         @methods   = @$type_name;
387         $type_name = undef;
388     }
389     if ( @methods == 1 && ref $methods[0] eq 'ARRAY' ) {
390         @methods = @{ $methods[0] };
391     }
392
393     register_type_constraint(
394         create_duck_type_constraint(
395             $type_name,
396             \@methods,
397         )
398     );
399 }
400
401 sub coerce {
402     my ( $type_name, @coercion_map ) = @_;
403     _install_type_coercions( $type_name, \@coercion_map );
404 }
405
406 # The trick of returning @_ lets us avoid having to specify a
407 # prototype. Perl will parse this:
408 #
409 # subtype 'Foo'
410 #     => as 'Str'
411 #     => where { ... }
412 #
413 # as this:
414 #
415 # subtype( 'Foo', as( 'Str', where { ... } ) );
416 #
417 # If as() returns all it's extra arguments, this just works, and
418 # preserves backwards compatibility.
419 sub as { { as => shift }, @_ }
420 sub where (&)       { { where       => $_[0] } }
421 sub message (&)     { { message     => $_[0] } }
422 sub optimize_as (&) { { optimize_as => $_[0] } }
423
424 sub from    {@_}
425 sub via (&) { $_[0] }
426
427 sub enum {
428     my ( $type_name, @values ) = @_;
429
430     # NOTE:
431     # if only an array-ref is passed then
432     # you get an anon-enum
433     # - SL
434     if ( ref $type_name eq 'ARRAY' ) {
435         @values == 0
436             || __PACKAGE__->_throw_error("enum called with an array reference and additional arguments. Did you mean to parenthesize the enum call's parameters?");
437
438         @values    = @$type_name;
439         $type_name = undef;
440     }
441     if ( @values == 1 && ref $values[0] eq 'ARRAY' ) {
442         @values = @{ $values[0] };
443     }
444
445     register_type_constraint(
446         create_enum_type_constraint(
447             $type_name,
448             \@values,
449         )
450     );
451 }
452
453 sub create_enum_type_constraint {
454     my ( $type_name, $values ) = @_;
455
456     Moose::Meta::TypeConstraint::Enum->new(
457         name => $type_name || '__ANON__',
458         values => $values,
459     );
460 }
461
462 sub create_duck_type_constraint {
463     my ( $type_name, $methods ) = @_;
464
465     Moose::Meta::TypeConstraint::DuckType->new(
466         name => $type_name || '__ANON__',
467         methods => $methods,
468     );
469 }
470
471 sub match_on_type {
472     my ($to_match, @cases) = @_;
473     my $default;
474     if (@cases % 2 != 0) {
475         $default = pop @cases;
476         (ref $default eq 'CODE')
477             || __PACKAGE__->_throw_error("Default case must be a CODE ref, not $default");
478     }
479     while (@cases) {
480         my ($type, $action) = splice @cases, 0, 2;
481
482         unless (blessed $type && $type->isa('Moose::Meta::TypeConstraint')) {
483             $type = find_or_parse_type_constraint($type)
484                  || __PACKAGE__->_throw_error("Cannot find or parse the type '$type'")
485         }
486
487         (ref $action eq 'CODE')
488             || __PACKAGE__->_throw_error("Match action must be a CODE ref, not $action");
489
490         if ($type->check($to_match)) {
491             local $_ = $to_match;
492             return $action->($to_match);
493         }
494     }
495     (defined $default)
496         || __PACKAGE__->_throw_error("No cases matched for $to_match");
497     {
498         local $_ = $to_match;
499         return $default->($to_match);
500     }
501 }
502
503
504 ## --------------------------------------------------------
505 ## desugaring functions ...
506 ## --------------------------------------------------------
507
508 sub _create_type_constraint ($$$;$$) {
509     my $name      = shift;
510     my $parent    = shift;
511     my $check     = shift;
512     my $message   = shift;
513     my $optimized = shift;
514
515     my $pkg_defined_in = scalar( caller(1) );
516
517     if ( defined $name ) {
518         my $type = $REGISTRY->get_type_constraint($name);
519
520         ( $type->_package_defined_in eq $pkg_defined_in )
521             || _confess(
522                   "The type constraint '$name' has already been created in "
523                 . $type->_package_defined_in
524                 . " and cannot be created again in "
525                 . $pkg_defined_in )
526             if defined $type;
527
528         $name =~ /^[\w:\.]+$/
529             or die qq{$name contains invalid characters for a type name.}
530             . qq{ Names can contain alphanumeric character, ":", and "."\n};
531     }
532
533     my %opts = (
534         name               => $name,
535         package_defined_in => $pkg_defined_in,
536
537         ( $check     ? ( constraint => $check )     : () ),
538         ( $message   ? ( message    => $message )   : () ),
539         ( $optimized ? ( optimized  => $optimized ) : () ),
540     );
541
542     my $constraint;
543     if (
544         defined $parent
545         and $parent
546         = blessed $parent
547         ? $parent
548         : find_or_create_isa_type_constraint($parent)
549         ) {
550         $constraint = $parent->create_child_type(%opts);
551     }
552     else {
553         $constraint = Moose::Meta::TypeConstraint->new(%opts);
554     }
555
556     $REGISTRY->add_type_constraint($constraint)
557         if defined $name;
558
559     return $constraint;
560 }
561
562 sub _install_type_coercions ($$) {
563     my ( $type_name, $coercion_map ) = @_;
564     my $type = find_type_constraint($type_name);
565     ( defined $type )
566         || __PACKAGE__->_throw_error(
567         "Cannot find type '$type_name', perhaps you forgot to load it");
568     if ( $type->has_coercion ) {
569         $type->coercion->add_type_coercions(@$coercion_map);
570     }
571     else {
572         my $type_coercion = Moose::Meta::TypeCoercion->new(
573             type_coercion_map => $coercion_map,
574             type_constraint   => $type
575         );
576         $type->coercion($type_coercion);
577     }
578 }
579
580 ## --------------------------------------------------------
581 ## type notation parsing ...
582 ## --------------------------------------------------------
583
584 {
585
586     # All I have to say is mugwump++ cause I know
587     # do not even have enough regexp-fu to be able
588     # to have written this (I can only barely
589     # understand it as it is)
590     # - SL
591
592     use re "eval";
593
594     my $valid_chars = qr{[\w:\.]};
595     my $type_atom   = qr{ (?>$valid_chars+) }x;
596     my $ws          = qr{ (?>\s*) }x;
597     my $op_union    = qr{ $ws \| $ws }x;
598
599     my ($type, $type_capture_parts, $type_with_parameter, $union, $any);
600     if (Class::MOP::IS_RUNNING_ON_5_10) {
601         my $type_pattern
602             = q{  (?&type_atom)  (?: \[ (?&ws)  (?&any)  (?&ws) \] )? };
603         my $type_capture_parts_pattern
604             = q{ ((?&type_atom)) (?: \[ (?&ws) ((?&any)) (?&ws) \] )? };
605         my $type_with_parameter_pattern
606             = q{  (?&type_atom)      \[ (?&ws)  (?&any)  (?&ws) \]    };
607         my $union_pattern
608             = q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) };
609         my $any_pattern
610             = q{ (?&type) | (?&union) };
611
612         my $defines = qr{(?(DEFINE)
613             (?<valid_chars>         $valid_chars)
614             (?<type_atom>           $type_atom)
615             (?<ws>                  $ws)
616             (?<op_union>            $op_union)
617             (?<type>                $type_pattern)
618             (?<type_capture_parts>  $type_capture_parts_pattern)
619             (?<type_with_parameter> $type_with_parameter_pattern)
620             (?<union>               $union_pattern)
621             (?<any>                 $any_pattern)
622         )}x;
623
624         $type                = qr{ $type_pattern                $defines }x;
625         $type_capture_parts  = qr{ $type_capture_parts_pattern  $defines }x;
626         $type_with_parameter = qr{ $type_with_parameter_pattern $defines }x;
627         $union               = qr{ $union_pattern               $defines }x;
628         $any                 = qr{ $any_pattern                 $defines }x;
629     }
630     else {
631         $type
632             = qr{  $type_atom  (?: \[ $ws  (??{$any})  $ws \] )? }x;
633         $type_capture_parts
634             = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x;
635         $type_with_parameter
636             = qr{  $type_atom      \[ $ws  (??{$any})  $ws \]    }x;
637         $union
638             = qr{ $type (?> (?: $op_union $type )+ ) }x;
639         $any
640             = qr{ $type | $union }x;
641     }
642
643
644     sub _parse_parameterized_type_constraint {
645         { no warnings 'void'; $any; }  # force capture of interpolated lexical
646         $_[0] =~ m{ $type_capture_parts }x;
647         return ( $1, $2 );
648     }
649
650     sub _detect_parameterized_type_constraint {
651         { no warnings 'void'; $any; }  # force capture of interpolated lexical
652         $_[0] =~ m{ ^ $type_with_parameter $ }x;
653     }
654
655     sub _parse_type_constraint_union {
656         { no warnings 'void'; $any; }  # force capture of interpolated lexical
657         my $given = shift;
658         my @rv;
659         while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
660             push @rv => $1;
661         }
662         ( pos($given) eq length($given) )
663             || __PACKAGE__->_throw_error( "'$given' didn't parse (parse-pos="
664                 . pos($given)
665                 . " and str-length="
666                 . length($given)
667                 . ")" );
668         @rv;
669     }
670
671     sub _detect_type_constraint_union {
672         { no warnings 'void'; $any; }  # force capture of interpolated lexical
673         $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
674     }
675 }
676
677 ## --------------------------------------------------------
678 # define some basic built-in types
679 ## --------------------------------------------------------
680
681 # By making these classes immutable before creating all the types we
682 # below, we avoid repeatedly calling the slow MOP-based accessors.
683 $_->make_immutable(
684     inline_constructor => 1,
685     constructor_name   => "_new",
686
687     # these are Class::MOP accessors, so they need inlining
688     inline_accessors => 1
689     ) for grep { $_->is_mutable }
690     map { Class::MOP::class_of($_) }
691     qw(
692     Moose::Meta::TypeConstraint
693     Moose::Meta::TypeConstraint::Union
694     Moose::Meta::TypeConstraint::Parameterized
695     Moose::Meta::TypeConstraint::Parameterizable
696     Moose::Meta::TypeConstraint::Class
697     Moose::Meta::TypeConstraint::Role
698     Moose::Meta::TypeConstraint::Enum
699     Moose::Meta::TypeConstraint::DuckType
700     Moose::Meta::TypeConstraint::Registry
701 );
702
703 type 'Any'  => where {1};    # meta-type including all
704 subtype 'Item' => as 'Any';  # base-type
705
706 subtype 'Undef'   => as 'Item' => where { !defined($_) };
707 subtype 'Defined' => as 'Item' => where { defined($_) };
708
709 subtype 'Bool' => as 'Item' =>
710     where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
711
712 subtype 'Value' => as 'Defined' => where { !ref($_) } =>
713     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Value;
714
715 subtype 'Ref' => as 'Defined' => where { ref($_) } =>
716     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref;
717
718 subtype 'Str' => as 'Value' => where { ref(\$_) eq 'SCALAR' } =>
719     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str;
720
721 subtype 'Num' => as 'Str' =>
722     where { Scalar::Util::looks_like_number($_) } =>
723     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Num;
724
725 subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ } =>
726     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
727
728 subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } =>
729     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
730 subtype 'RegexpRef' => as 'Ref' =>
731     where(\&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef) =>
732     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
733 subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } =>
734     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
735
736 # NOTE:
737 # scalar filehandles are GLOB refs,
738 # but a GLOB ref is not always a filehandle
739 subtype 'FileHandle' => as 'GlobRef' => where {
740     Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") );
741 } => optimize_as
742     \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
743
744 subtype 'Object' => as 'Ref' =>
745     where { blessed($_) } =>
746     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
747
748 # This type is deprecated.
749 subtype 'Role' => as 'Object' => where { $_->can('does') } =>
750     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role;
751
752 my $_class_name_checker = sub { };
753
754 subtype 'ClassName' => as 'Str' =>
755     where { Class::MOP::is_class_loaded($_) } => optimize_as
756     \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName;
757
758 subtype 'RoleName' => as 'ClassName' => where {
759     (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role');
760 } => optimize_as
761     \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName;
762
763 ## --------------------------------------------------------
764 # parameterizable types ...
765
766 $REGISTRY->add_type_constraint(
767     Moose::Meta::TypeConstraint::Parameterizable->new(
768         name               => 'ScalarRef',
769         package_defined_in => __PACKAGE__,
770         parent             => find_type_constraint('Ref'),
771         constraint         => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' },
772         optimized =>
773             \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef,
774         constraint_generator => sub {
775             my $type_parameter = shift;
776             my $check          = $type_parameter->_compiled_type_constraint;
777             return sub {
778                 return $check->(${ $_ });
779             };
780         }
781     )
782 );
783
784 $REGISTRY->add_type_constraint(
785     Moose::Meta::TypeConstraint::Parameterizable->new(
786         name               => 'ArrayRef',
787         package_defined_in => __PACKAGE__,
788         parent             => find_type_constraint('Ref'),
789         constraint         => sub { ref($_) eq 'ARRAY' },
790         optimized =>
791             \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
792         constraint_generator => sub {
793             my $type_parameter = shift;
794             my $check          = $type_parameter->_compiled_type_constraint;
795             return sub {
796                 foreach my $x (@$_) {
797                     ( $check->($x) ) || return;
798                 }
799                 1;
800                 }
801         }
802     )
803 );
804
805 $REGISTRY->add_type_constraint(
806     Moose::Meta::TypeConstraint::Parameterizable->new(
807         name               => 'HashRef',
808         package_defined_in => __PACKAGE__,
809         parent             => find_type_constraint('Ref'),
810         constraint         => sub { ref($_) eq 'HASH' },
811         optimized =>
812             \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
813         constraint_generator => sub {
814             my $type_parameter = shift;
815             my $check          = $type_parameter->_compiled_type_constraint;
816             return sub {
817                 foreach my $x ( values %$_ ) {
818                     ( $check->($x) ) || return;
819                 }
820                 1;
821                 }
822         }
823     )
824 );
825
826 $REGISTRY->add_type_constraint(
827     Moose::Meta::TypeConstraint::Parameterizable->new(
828         name                 => 'Maybe',
829         package_defined_in   => __PACKAGE__,
830         parent               => find_type_constraint('Item'),
831         constraint           => sub {1},
832         constraint_generator => sub {
833             my $type_parameter = shift;
834             my $check          = $type_parameter->_compiled_type_constraint;
835             return sub {
836                 return 1 if not( defined($_) ) || $check->($_);
837                 return;
838                 }
839         }
840     )
841 );
842
843 my @PARAMETERIZABLE_TYPES
844     = map { $REGISTRY->get_type_constraint($_) } qw[ScalarRef ArrayRef HashRef Maybe];
845
846 sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES}
847
848 sub add_parameterizable_type {
849     my $type = shift;
850     ( blessed $type
851             && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') )
852         || __PACKAGE__->_throw_error(
853         "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type"
854         );
855     push @PARAMETERIZABLE_TYPES => $type;
856 }
857
858 ## --------------------------------------------------------
859 # end of built-in types ...
860 ## --------------------------------------------------------
861
862 {
863     my @BUILTINS = list_all_type_constraints();
864     sub list_all_builtin_type_constraints {@BUILTINS}
865 }
866
867 sub _throw_error {
868     shift;
869     require Moose;
870     unshift @_, 'Moose';
871     goto &Moose::throw_error;
872 }
873
874 1;
875
876 # ABSTRACT: Type constraint system for Moose
877
878 __END__
879
880 =pod
881
882 =head1 SYNOPSIS
883
884   use Moose::Util::TypeConstraints;
885
886   subtype 'Natural'
887       => as 'Int'
888       => where { $_ > 0 };
889
890   subtype 'NaturalLessThanTen'
891       => as 'Natural'
892       => where { $_ < 10 }
893       => message { "This number ($_) is not less than ten!" };
894
895   coerce 'Num'
896       => from 'Str'
897         => via { 0+$_ };
898
899   enum 'RGBColors' => qw(red green blue);
900
901   no Moose::Util::TypeConstraints;
902
903 =head1 DESCRIPTION
904
905 This module provides Moose with the ability to create custom type
906 constraints to be used in attribute definition.
907
908 =head2 Important Caveat
909
910 This is B<NOT> a type system for Perl 5. These are type constraints,
911 and they are not used by Moose unless you tell it to. No type
912 inference is performed, expressions are not typed, etc. etc. etc.
913
914 A type constraint is at heart a small "check if a value is valid"
915 function. A constraint can be associated with an attribute. This
916 simplifies parameter validation, and makes your code clearer to read,
917 because you can refer to constraints by name.
918
919 =head2 Slightly Less Important Caveat
920
921 It is B<always> a good idea to quote your type names.
922
923 This prevents Perl from trying to execute the call as an indirect
924 object call. This can be an issue when you have a subtype with the
925 same name as a valid class.
926
927 For instance:
928
929   subtype DateTime => as Object => where { $_->isa('DateTime') };
930
931 will I<just work>, while this:
932
933   use DateTime;
934   subtype DateTime => as Object => where { $_->isa('DateTime') };
935
936 will fail silently and cause many headaches. The simple way to solve
937 this, as well as future proof your subtypes from classes which have
938 yet to have been created, is to quote the type name:
939
940   use DateTime;
941   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
942
943 =head2 Default Type Constraints
944
945 This module also provides a simple hierarchy for Perl 5 types, here is
946 that hierarchy represented visually.
947
948   Any
949   Item
950       Bool
951       Maybe[`a]
952       Undef
953       Defined
954           Value
955               Str
956                   Num
957                       Int
958                   ClassName
959                   RoleName
960           Ref
961               ScalarRef[`a]
962               ArrayRef[`a]
963               HashRef[`a]
964               CodeRef
965               RegexpRef
966               GlobRef
967                   FileHandle
968               Object
969
970 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
971 parameterized, this means you can say:
972
973   ArrayRef[Int]    # an array of integers
974   HashRef[CodeRef] # a hash of str to CODE ref mappings
975   ScalarRef[Int]   # a reference to an integer
976   Maybe[Str]       # value may be a string, may be undefined
977
978 If Moose finds a name in brackets that it does not recognize as an
979 existing type, it assumes that this is a class name, for example
980 C<ArrayRef[DateTime]>.
981
982 B<NOTE:> Unless you parameterize a type, then it is invalid to include
983 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
984 name, I<not> as a parameterization of C<ArrayRef>.
985
986 B<NOTE:> The C<Undef> type constraint for the most part works
987 correctly now, but edge cases may still exist, please use it
988 sparingly.
989
990 B<NOTE:> The C<ClassName> type constraint does a complex package
991 existence check. This means that your class B<must> be loaded for this
992 type constraint to pass.
993
994 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
995 name> which is a role, like C<'MyApp::Role::Comparable'>.
996
997 =head2 Type Constraint Naming
998
999 Type name declared via this module can only contain alphanumeric
1000 characters, colons (:), and periods (.).
1001
1002 Since the types created by this module are global, it is suggested
1003 that you namespace your types just as you would namespace your
1004 modules. So instead of creating a I<Color> type for your
1005 B<My::Graphics> module, you would call the type
1006 I<My::Graphics::Types::Color> instead.
1007
1008 =head2 Use with Other Constraint Modules
1009
1010 This module can play nicely with other constraint modules with some
1011 slight tweaking. The C<where> clause in types is expected to be a
1012 C<CODE> reference which checks it's first argument and returns a
1013 boolean. Since most constraint modules work in a similar way, it
1014 should be simple to adapt them to work with Moose.
1015
1016 For instance, this is how you could use it with
1017 L<Declare::Constraints::Simple> to declare a completely new type.
1018
1019   type 'HashOfArrayOfObjects',
1020       {
1021       where => IsHashRef(
1022           -keys   => HasLength,
1023           -values => IsArrayRef(IsObject)
1024       )
1025   };
1026
1027 For more examples see the F<t/200_examples/004_example_w_DCS.t> test
1028 file.
1029
1030 Here is an example of using L<Test::Deep> and it's non-test
1031 related C<eq_deeply> function.
1032
1033   type 'ArrayOfHashOfBarsAndRandomNumbers'
1034       => where {
1035           eq_deeply($_,
1036               array_each(subhashof({
1037                   bar           => isa('Bar'),
1038                   random_number => ignore()
1039               })))
1040         };
1041
1042 For a complete example see the
1043 F<t/200_examples/005_example_w_TestDeep.t> test file.
1044
1045 =head2 Error messages
1046
1047 Type constraints can also specify custom error messages, for when they fail to
1048 validate. This is provided as just another coderef, which receives the invalid
1049 value in C<$_>, as in:
1050
1051   subtype 'PositiveInt',
1052        as 'Int',
1053        where { $_ > 0 },
1054        message { "$_ is not a positive integer!" };
1055
1056 If no message is specified, a default message will be used, which indicates
1057 which type constraint was being used and what value failed. If
1058 L<Devel::PartialDump> (version 0.14 or higher) is installed, it will be used to
1059 display the invalid value, otherwise it will just be printed as is.
1060
1061 =head1 FUNCTIONS
1062
1063 =head2 Type Constraint Constructors
1064
1065 The following functions are used to create type constraints.  They
1066 will also register the type constraints your create in a global
1067 registry that is used to look types up by name.
1068
1069 See the L</SYNOPSIS> for an example of how to use these.
1070
1071 =over 4
1072
1073 =item B<< subtype 'Name' => as 'Parent' => where { } ... >>
1074
1075 This creates a named subtype.
1076
1077 If you provide a parent that Moose does not recognize, it will
1078 automatically create a new class type constraint for this name.
1079
1080 When creating a named type, the C<subtype> function should either be
1081 called with the sugar helpers (C<where>, C<message>, etc), or with a
1082 name and a hashref of parameters:
1083
1084  subtype( 'Foo', { where => ..., message => ... } );
1085
1086 The valid hashref keys are C<as> (the parent), C<where>, C<message>,
1087 and C<optimize_as>.
1088
1089 =item B<< subtype as 'Parent' => where { } ... >>
1090
1091 This creates an unnamed subtype and will return the type
1092 constraint meta-object, which will be an instance of
1093 L<Moose::Meta::TypeConstraint>.
1094
1095 When creating an anonymous type, the C<subtype> function should either
1096 be called with the sugar helpers (C<where>, C<message>, etc), or with
1097 just a hashref of parameters:
1098
1099  subtype( { where => ..., message => ... } );
1100
1101 =item B<class_type ($class, ?$options)>
1102
1103 Creates a new subtype of C<Object> with the name C<$class> and the
1104 metaclass L<Moose::Meta::TypeConstraint::Class>.
1105
1106 =item B<role_type ($role, ?$options)>
1107
1108 Creates a C<Role> type constraint with the name C<$role> and the
1109 metaclass L<Moose::Meta::TypeConstraint::Role>.
1110
1111 =item B<maybe_type ($type)>
1112
1113 Creates a type constraint for either C<undef> or something of the
1114 given type.
1115
1116 =item B<duck_type ($name, \@methods)>
1117
1118 This will create a subtype of Object and test to make sure the value
1119 C<can()> do the methods in C<\@methods>.
1120
1121 This is intended as an easy way to accept non-Moose objects that
1122 provide a certain interface. If you're using Moose classes, we
1123 recommend that you use a C<requires>-only Role instead.
1124
1125 =item B<duck_type (\@methods)>
1126
1127 If passed an ARRAY reference as the only parameter instead of the
1128 C<$name>, C<\@methods> pair, this will create an unnamed duck type.
1129 This can be used in an attribute definition like so:
1130
1131   has 'cache' => (
1132       is  => 'ro',
1133       isa => duck_type( [qw( get_set )] ),
1134   );
1135
1136 =item B<enum ($name, \@values)>
1137
1138 This will create a basic subtype for a given set of strings.
1139 The resulting constraint will be a subtype of C<Str> and
1140 will match any of the items in C<\@values>. It is case sensitive.
1141 See the L</SYNOPSIS> for a simple example.
1142
1143 B<NOTE:> This is not a true proper enum type, it is simply
1144 a convenient constraint builder.
1145
1146 =item B<enum (\@values)>
1147
1148 If passed an ARRAY reference as the only parameter instead of the
1149 C<$name>, C<\@values> pair, this will create an unnamed enum. This
1150 can then be used in an attribute definition like so:
1151
1152   has 'sort_order' => (
1153       is  => 'ro',
1154       isa => enum([qw[ ascending descending ]]),
1155   );
1156
1157 =item B<as 'Parent'>
1158
1159 This is just sugar for the type constraint construction syntax.
1160
1161 It takes a single argument, which is the name of a parent type.
1162
1163 =item B<where { ... }>
1164
1165 This is just sugar for the type constraint construction syntax.
1166
1167 It takes a subroutine reference as an argument. When the type
1168 constraint is tested, the reference is run with the value to be tested
1169 in C<$_>. This reference should return true or false to indicate
1170 whether or not the constraint check passed.
1171
1172 =item B<message { ... }>
1173
1174 This is just sugar for the type constraint construction syntax.
1175
1176 It takes a subroutine reference as an argument. When the type
1177 constraint fails, then the code block is run with the value provided
1178 in C<$_>. This reference should return a string, which will be used in
1179 the text of the exception thrown.
1180
1181 =item B<optimize_as { ... }>
1182
1183 This can be used to define a "hand optimized" version of your
1184 type constraint which can be used to avoid traversing a subtype
1185 constraint hierarchy.
1186
1187 B<NOTE:> You should only use this if you know what you are doing.
1188 All the built in types use this, so your subtypes (assuming they
1189 are shallow) will not likely need to use this.
1190
1191 =item B<< type 'Name' => where { } ... >>
1192
1193 This creates a base type, which has no parent.
1194
1195 The C<type> function should either be called with the sugar helpers
1196 (C<where>, C<message>, etc), or with a name and a hashref of
1197 parameters:
1198
1199   type( 'Foo', { where => ..., message => ... } );
1200
1201 The valid hashref keys are C<where>, C<message>, and C<optimize_as>.
1202
1203 =back
1204
1205 =head2 Type Constraint Utilities
1206
1207 =over 4
1208
1209 =item B<< match_on_type $value => ( $type => \&action, ... ?\&default ) >>
1210
1211 This is a utility function for doing simple type based dispatching similar to
1212 match/case in OCaml and case/of in Haskell. It is not as featureful as those
1213 languages, nor does not it support any kind of automatic destructuring
1214 bind. Here is a simple Perl pretty printer dispatching over the core Moose
1215 types.
1216
1217   sub ppprint {
1218       my $x = shift;
1219       match_on_type $x => (
1220           HashRef => sub {
1221               my $hash = shift;
1222               '{ '
1223                   . (
1224                   join ", " => map { $_ . ' => ' . ppprint( $hash->{$_} ) }
1225                       sort keys %$hash
1226                   ) . ' }';
1227           },
1228           ArrayRef => sub {
1229               my $array = shift;
1230               '[ ' . ( join ", " => map { ppprint($_) } @$array ) . ' ]';
1231           },
1232           CodeRef   => sub {'sub { ... }'},
1233           RegexpRef => sub { 'qr/' . $_ . '/' },
1234           GlobRef   => sub { '*' . B::svref_2object($_)->NAME },
1235           Object    => sub { $_->can('to_string') ? $_->to_string : $_ },
1236           ScalarRef => sub { '\\' . ppprint( ${$_} ) },
1237           Num       => sub {$_},
1238           Str       => sub { '"' . $_ . '"' },
1239           Undef     => sub {'undef'},
1240           => sub { die "I don't know what $_ is" }
1241       );
1242   }
1243
1244 Or a simple JSON serializer:
1245
1246   sub to_json {
1247       my $x = shift;
1248       match_on_type $x => (
1249           HashRef => sub {
1250               my $hash = shift;
1251               '{ '
1252                   . (
1253                   join ", " =>
1254                       map { '"' . $_ . '" : ' . to_json( $hash->{$_} ) }
1255                       sort keys %$hash
1256                   ) . ' }';
1257           },
1258           ArrayRef => sub {
1259               my $array = shift;
1260               '[ ' . ( join ", " => map { to_json($_) } @$array ) . ' ]';
1261           },
1262           Num   => sub {$_},
1263           Str   => sub { '"' . $_ . '"' },
1264           Undef => sub {'null'},
1265           => sub { die "$_ is not acceptable json type" }
1266       );
1267   }
1268
1269 The matcher is done by mapping a C<$type> to an C<\&action>. The C<$type> can
1270 be either a string type or a L<Moose::Meta::TypeConstraint> object, and
1271 C<\&action> is a subroutine reference. This function will dispatch on the
1272 first match for C<$value>. It is possible to have a catch-all by providing an
1273 additional subroutine reference as the final argument to C<match_on_type>.
1274
1275 =back
1276
1277 =head2 Type Coercion Constructors
1278
1279 You can define coercions for type constraints, which allow you to
1280 automatically transform values to something valid for the type
1281 constraint. If you ask your accessor to coerce, then Moose will run
1282 the type-coercion code first, followed by the type constraint
1283 check. This feature should be used carefully as it is very powerful
1284 and could easily take off a limb if you are not careful.
1285
1286 See the L</SYNOPSIS> for an example of how to use these.
1287
1288 =over 4
1289
1290 =item B<< coerce 'Name' => from 'OtherName' => via { ... }  >>
1291
1292 This defines a coercion from one type to another. The C<Name> argument
1293 is the type you are coercing I<to>.
1294
1295 To define multiple coercions, supply more sets of from/via pairs:
1296
1297   coerce 'Name' =>
1298     from 'OtherName' => via { ... },
1299     from 'ThirdName' => via { ... };
1300
1301 =item B<from 'OtherName'>
1302
1303 This is just sugar for the type coercion construction syntax.
1304
1305 It takes a single type name (or type object), which is the type being
1306 coerced I<from>.
1307
1308 =item B<via { ... }>
1309
1310 This is just sugar for the type coercion construction syntax.
1311
1312 It takes a subroutine reference. This reference will be called with
1313 the value to be coerced in C<$_>. It is expected to return a new value
1314 of the proper type for the coercion.
1315
1316 =back
1317
1318 =head2 Creating and Finding Type Constraints
1319
1320 These are additional functions for creating and finding type
1321 constraints. Most of these functions are not available for
1322 importing. The ones that are importable as specified.
1323
1324 =over 4
1325
1326 =item B<find_type_constraint($type_name)>
1327
1328 This function can be used to locate the L<Moose::Meta::TypeConstraint>
1329 object for a named type.
1330
1331 This function is importable.
1332
1333 =item B<register_type_constraint($type_object)>
1334
1335 This function will register a L<Moose::Meta::TypeConstraint> with the
1336 global type registry.
1337
1338 This function is importable.
1339
1340 =item B<normalize_type_constraint_name($type_constraint_name)>
1341
1342 This method takes a type constraint name and returns the normalized
1343 form. This removes any whitespace in the string.
1344
1345 =item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)>
1346
1347 This can take a union type specification like C<'Int|ArrayRef[Int]'>,
1348 or a list of names. It returns a new
1349 L<Moose::Meta::TypeConstraint::Union> object.
1350
1351 =item B<create_parameterized_type_constraint($type_name)>
1352
1353 Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>,
1354 this will create a new L<Moose::Meta::TypeConstraint::Parameterized>
1355 object. The C<BaseType> must exist already exist as a parameterizable
1356 type.
1357
1358 =item B<create_class_type_constraint($class, $options)>
1359
1360 Given a class name this function will create a new
1361 L<Moose::Meta::TypeConstraint::Class> object for that class name.
1362
1363 The C<$options> is a hash reference that will be passed to the
1364 L<Moose::Meta::TypeConstraint::Class> constructor (as a hash).
1365
1366 =item B<create_role_type_constraint($role, $options)>
1367
1368 Given a role name this function will create a new
1369 L<Moose::Meta::TypeConstraint::Role> object for that role name.
1370
1371 The C<$options> is a hash reference that will be passed to the
1372 L<Moose::Meta::TypeConstraint::Role> constructor (as a hash).
1373
1374 =item B<create_enum_type_constraint($name, $values)>
1375
1376 Given a enum name this function will create a new
1377 L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
1378
1379 =item B<create_duck_type_constraint($name, $methods)>
1380
1381 Given a duck type name this function will create a new
1382 L<Moose::Meta::TypeConstraint::DuckType> object for that enum name.
1383
1384 =item B<find_or_parse_type_constraint($type_name)>
1385
1386 Given a type name, this first attempts to find a matching constraint
1387 in the global registry.
1388
1389 If the type name is a union or parameterized type, it will create a
1390 new object of the appropriate, but if given a "regular" type that does
1391 not yet exist, it simply returns false.
1392
1393 When given a union or parameterized type, the member or base type must
1394 already exist.
1395
1396 If it creates a new union or parameterized type, it will add it to the
1397 global registry.
1398
1399 =item B<find_or_create_isa_type_constraint($type_name)>
1400
1401 =item B<find_or_create_does_type_constraint($type_name)>
1402
1403 These functions will first call C<find_or_parse_type_constraint>. If
1404 that function does not return a type, a new type object will
1405 be created.
1406
1407 The C<isa> variant will use C<create_class_type_constraint> and the
1408 C<does> variant will use C<create_role_type_constraint>.
1409
1410 =item B<get_type_constraint_registry>
1411
1412 Returns the L<Moose::Meta::TypeConstraint::Registry> object which
1413 keeps track of all type constraints.
1414
1415 =item B<list_all_type_constraints>
1416
1417 This will return a list of type constraint names in the global
1418 registry. You can then fetch the actual type object using
1419 C<find_type_constraint($type_name)>.
1420
1421 =item B<list_all_builtin_type_constraints>
1422
1423 This will return a list of builtin type constraints, meaning those
1424 which are defined in this module. See the L<Default Type Constraints>
1425 section for a complete list.
1426
1427 =item B<export_type_constraints_as_functions>
1428
1429 This will export all the current type constraints as functions into
1430 the caller's namespace (C<Int()>, C<Str()>, etc). Right now, this is
1431 mostly used for testing, but it might prove useful to others.
1432
1433 =item B<get_all_parameterizable_types>
1434
1435 This returns all the parameterizable types that have been registered,
1436 as a list of type objects.
1437
1438 =item B<add_parameterizable_type($type)>
1439
1440 Adds C<$type> to the list of parameterizable types
1441
1442 =back
1443
1444 =head1 BUGS
1445
1446 See L<Moose/BUGS> for details on reporting bugs.
1447
1448 =cut