lib/Moose/Util/TypeConstraints.pm

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