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,
 374             'Object',
 375             sub {
 376                 my $obj = $_;
 377                 return 0 unless all { $obj->can($_) } @methods;
 378                 return 1;
 379             },
 380             sub {
 381                 my $obj = $_;
 382                 my @missing_methods = grep { !$obj->can($_) } @methods;
 383                 return
 384                     "${\blessed($obj)} is missing methods '@missing_methods'";
 385             },
 386         )
 387     );
 388 }
 389
 390 sub coerce {
 391     my ( $type_name, @coercion_map ) = @_;
 392     _install_type_coercions( $type_name, \@coercion_map );
 393 }
 394
 395 # The trick of returning @_ lets us avoid having to specify a
 396 # prototype. Perl will parse this:
 397 #
 398 # subtype 'Foo'
 399 #     => as 'Str'
 400 #     => where { ... }
 401 #
 402 # as this:
 403 #
 404 # subtype( 'Foo', as( 'Str', where { ... } ) );
 405 #
 406 # If as() returns all it's extra arguments, this just works, and
 407 # preserves backwards compatibility.
 408 sub as { { as => shift }, @_ }
 409 sub where (&)       { { where       => $_[0] } }
 410 sub message (&)     { { message     => $_[0] } }
 411 sub optimize_as (&) { { optimize_as => $_[0] } }
 412
 413 sub from    {@_}
 414 sub via (&) { $_[0] }
 415
 416 sub enum {
 417     my ( $type_name, @values ) = @_;
 418
 419     # NOTE:
 420     # if only an array-ref is passed then
 421     # you get an anon-enum
 422     # - SL
 423     if ( ref $type_name eq 'ARRAY' && !@values ) {
 424         @values    = @$type_name;
 425         $type_name = undef;
 426     }
 427     ( scalar @values >= 2 )
 428         || __PACKAGE__->_throw_error(
 429         "You must have at least two values to enumerate through");
 430     my %valid = map { $_ => 1 } @values;
 431
 432     register_type_constraint(
 433         create_enum_type_constraint(
 434             $type_name,
 435             \@values,
 436         )
 437     );
 438 }
 439
 440 sub create_enum_type_constraint {
 441     my ( $type_name, $values ) = @_;
 442
 443     Moose::Meta::TypeConstraint::Enum->new(
 444         name => $type_name || '__ANON__',
 445         values => $values,
 446     );
 447 }
 448
 449 ## --------------------------------------------------------
 450 ## desugaring functions ...
 451 ## --------------------------------------------------------
 452
 453 sub _create_type_constraint ($$$;$$) {
 454     my $name      = shift;
 455     my $parent    = shift;
 456     my $check     = shift;
 457     my $message   = shift;
 458     my $optimized = shift;
 459
 460     my $pkg_defined_in = scalar( caller(1) );
 461
 462     if ( defined $name ) {
 463         my $type = $REGISTRY->get_type_constraint($name);
 464
 465         ( $type->_package_defined_in eq $pkg_defined_in )
 466             || _confess(
 467                   "The type constraint '$name' has already been created in "
 468                 . $type->_package_defined_in
 469                 . " and cannot be created again in "
 470                 . $pkg_defined_in )
 471             if defined $type;
 472
 473         $name =~ /^[\w:\.]+$/
 474             or die qq{$name contains invalid characters for a type name.}
 475             . qq{ Names can contain alphanumeric character, ":", and "."\n};
 476     }
 477
 478     my %opts = (
 479         name               => $name,
 480         package_defined_in => $pkg_defined_in,
 481
 482         ( $check     ? ( constraint => $check )     : () ),
 483         ( $message   ? ( message    => $message )   : () ),
 484         ( $optimized ? ( optimized  => $optimized ) : () ),
 485     );
 486
 487     my $constraint;
 488     if (
 489         defined $parent
 490         and $parent
 491         = blessed $parent
 492         ? $parent
 493         : find_or_create_isa_type_constraint($parent)
 494         ) {
 495         $constraint = $parent->create_child_type(%opts);
 496     }
 497     else {
 498         $constraint = Moose::Meta::TypeConstraint->new(%opts);
 499     }
 500
 501     $REGISTRY->add_type_constraint($constraint)
 502         if defined $name;
 503
 504     return $constraint;
 505 }
 506
 507 sub _install_type_coercions ($$) {
 508     my ( $type_name, $coercion_map ) = @_;
 509     my $type = find_type_constraint($type_name);
 510     ( defined $type )
 511         || __PACKAGE__->_throw_error(
 512         "Cannot find type '$type_name', perhaps you forgot to load it.");
 513     if ( $type->has_coercion ) {
 514         $type->coercion->add_type_coercions(@$coercion_map);
 515     }
 516     else {
 517         my $type_coercion = Moose::Meta::TypeCoercion->new(
 518             type_coercion_map => $coercion_map,
 519             type_constraint   => $type
 520         );
 521         $type->coercion($type_coercion);
 522     }
 523 }
 524
 525 ## --------------------------------------------------------
 526 ## type notation parsing ...
 527 ## --------------------------------------------------------
 528
 529 {
 530
 531     # All I have to say is mugwump++ cause I know
 532     # do not even have enough regexp-fu to be able
 533     # to have written this (I can only barely
 534     # understand it as it is)
 535     # - SL
 536
 537     use re "eval";
 538
 539     my $valid_chars = qr{[\w:\.]};
 540     my $type_atom   = qr{ $valid_chars+ };
 541
 542     my $any;
 543
 544     my $type = qr{  $valid_chars+  (?: \[ \s* (??{$any})   \s* \] )? }x;
 545     my $type_capture_parts
 546         = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x;
 547     my $type_with_parameter
 548         = qr{  $valid_chars+      \[ \s* (??{$any})   \s* \]    }x;
 549
 550     my $op_union = qr{ \s* \| \s* }x;
 551     my $union    = qr{ $type (?: $op_union $type )+ }x;
 552
 553     $any = qr{ $type | $union }x;
 554
 555     sub _parse_parameterized_type_constraint {
 556         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 557         $_[0] =~ m{ $type_capture_parts }x;
 558         return ( $1, $2 );
 559     }
 560
 561     sub _detect_parameterized_type_constraint {
 562         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 563         $_[0] =~ m{ ^ $type_with_parameter $ }x;
 564     }
 565
 566     sub _parse_type_constraint_union {
 567         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 568         my $given = shift;
 569         my @rv;
 570         while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
 571             push @rv => $1;
 572         }
 573         ( pos($given) eq length($given) )
 574             || __PACKAGE__->_throw_error( "'$given' didn't parse (parse-pos="
 575                 . pos($given)
 576                 . " and str-length="
 577                 . length($given)
 578                 . ")" );
 579         @rv;
 580     }
 581
 582     sub _detect_type_constraint_union {
 583         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 584         $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
 585     }
 586 }
 587
 588 ## --------------------------------------------------------
 589 # define some basic built-in types
 590 ## --------------------------------------------------------
 591
 592 # By making these classes immutable before creating all the types we
 593 # below, we avoid repeatedly calling the slow MOP-based accessors.
 594 $_->make_immutable(
 595     inline_constructor => 1,
 596     constructor_name   => "_new",
 597
 598     # these are Class::MOP accessors, so they need inlining
 599     inline_accessors => 1
 600     ) for grep { $_->is_mutable }
 601     map { Class::MOP::class_of($_) }
 602     qw(
 603     Moose::Meta::TypeConstraint
 604     Moose::Meta::TypeConstraint::Union
 605     Moose::Meta::TypeConstraint::Parameterized
 606     Moose::Meta::TypeConstraint::Parameterizable
 607     Moose::Meta::TypeConstraint::Class
 608     Moose::Meta::TypeConstraint::Role
 609     Moose::Meta::TypeConstraint::Enum
 610     Moose::Meta::TypeConstraint::Registry
 611 );
 612
 613 type 'Any'  => where {1};    # meta-type including all
 614 type 'Item' => where {1};    # base-type
 615
 616 subtype 'Undef'   => as 'Item' => where { !defined($_) };
 617 subtype 'Defined' => as 'Item' => where { defined($_) };
 618
 619 subtype 'Bool' => as 'Item' =>
 620     where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
 621
 622 subtype 'Value' => as 'Defined' => where { !ref($_) } =>
 623     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Value;
 624
 625 subtype 'Ref' => as 'Defined' => where { ref($_) } =>
 626     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref;
 627
 628 subtype 'Str' => as 'Value' => where {1} =>
 629     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str;
 630
 631 subtype 'Num' => as 'Value' =>
 632     where { Scalar::Util::looks_like_number($_) } =>
 633     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Num;
 634
 635 subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ } =>
 636     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
 637
 638 subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } =>
 639     optimize_as
 640     \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef;
 641 subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } =>
 642     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
 643 subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } =>
 644     optimize_as
 645     \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
 646 subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } =>
 647     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
 648
 649 # NOTE:
 650 # scalar filehandles are GLOB refs,
 651 # but a GLOB ref is not always a filehandle
 652 subtype 'FileHandle' => as 'GlobRef' => where {
 653     Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") );
 654 } => optimize_as
 655     \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
 656
 657 # NOTE:
 658 # blessed(qr/.../) returns true,.. how odd
 659 subtype 'Object' => as 'Ref' =>
 660     where { blessed($_) && blessed($_) ne 'Regexp' } =>
 661     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
 662
 663 subtype 'Role' => as 'Object' => where { $_->can('does') } =>
 664     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role;
 665
 666 my $_class_name_checker = sub { };
 667
 668 subtype 'ClassName' => as 'Str' =>
 669     where { Class::MOP::is_class_loaded($_) } => optimize_as
 670     \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName;
 671
 672 subtype 'RoleName' => as 'ClassName' => where {
 673     ( ( $_->can('meta') || return )->($_) || return )
 674         ->isa('Moose::Meta::Role');
 675 } => optimize_as
 676     \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName;
 677
 678 ## --------------------------------------------------------
 679 # parameterizable types ...
 680
 681 $REGISTRY->add_type_constraint(
 682     Moose::Meta::TypeConstraint::Parameterizable->new(
 683         name               => 'ArrayRef',
 684         package_defined_in => __PACKAGE__,
 685         parent             => find_type_constraint('Ref'),
 686         constraint         => sub { ref($_) eq 'ARRAY' },
 687         optimized =>
 688             \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
 689         constraint_generator => sub {
 690             my $type_parameter = shift;
 691             my $check          = $type_parameter->_compiled_type_constraint;
 692             return sub {
 693                 foreach my $x (@$_) {
 694                     ( $check->($x) ) || return;
 695                 }
 696                 1;
 697                 }
 698         }
 699     )
 700 );
 701
 702 $REGISTRY->add_type_constraint(
 703     Moose::Meta::TypeConstraint::Parameterizable->new(
 704         name               => 'HashRef',
 705         package_defined_in => __PACKAGE__,
 706         parent             => find_type_constraint('Ref'),
 707         constraint         => sub { ref($_) eq 'HASH' },
 708         optimized =>
 709             \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
 710         constraint_generator => sub {
 711             my $type_parameter = shift;
 712             my $check          = $type_parameter->_compiled_type_constraint;
 713             return sub {
 714                 foreach my $x ( values %$_ ) {
 715                     ( $check->($x) ) || return;
 716                 }
 717                 1;
 718                 }
 719         }
 720     )
 721 );
 722
 723 $REGISTRY->add_type_constraint(
 724     Moose::Meta::TypeConstraint::Parameterizable->new(
 725         name                 => 'Maybe',
 726         package_defined_in   => __PACKAGE__,
 727         parent               => find_type_constraint('Item'),
 728         constraint           => sub {1},
 729         constraint_generator => sub {
 730             my $type_parameter = shift;
 731             my $check          = $type_parameter->_compiled_type_constraint;
 732             return sub {
 733                 return 1 if not( defined($_) ) || $check->($_);
 734                 return;
 735                 }
 736         }
 737     )
 738 );
 739
 740 my @PARAMETERIZABLE_TYPES
 741     = map { $REGISTRY->get_type_constraint($_) } qw[ArrayRef HashRef Maybe];
 742
 743 sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES}
 744
 745 sub add_parameterizable_type {
 746     my $type = shift;
 747     ( blessed $type
 748             && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') )
 749         || __PACKAGE__->_throw_error(
 750         "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type"
 751         );
 752     push @PARAMETERIZABLE_TYPES => $type;
 753 }
 754
 755 ## --------------------------------------------------------
 756 # end of built-in types ...
 757 ## --------------------------------------------------------
 758
 759 {
 760     my @BUILTINS = list_all_type_constraints();
 761     sub list_all_builtin_type_constraints {@BUILTINS}
 762 }
 763
 764 sub _throw_error {
 765     shift;
 766     require Moose;
 767     unshift @_, 'Moose';
 768     goto &Moose::throw_error;
 769 }
 770
 771 1;
 772
 773 __END__
 774
 775 =pod
 776
 777 =head1 NAME
 778
 779 Moose::Util::TypeConstraints - Type constraint system for Moose
 780
 781 =head1 SYNOPSIS
 782
 783   use Moose::Util::TypeConstraints;
 784
 785   subtype 'Natural'
 786       => as 'Int'
 787       => where { $_ > 0 };
 788
 789   subtype 'NaturalLessThanTen'
 790       => as 'Natural'
 791       => where { $_ < 10 }
 792       => message { "This number ($_) is not less than ten!" };
 793
 794   coerce 'Num'
 795       => from 'Str'
 796         => via { 0+$_ };
 797
 798   enum 'RGBColors' => qw(red green blue);
 799
 800   no Moose::Util::TypeConstraints;
 801
 802 =head1 DESCRIPTION
 803
 804 This module provides Moose with the ability to create custom type
 805 constraints to be used in attribute definition.
 806
 807 =head2 Important Caveat
 808
 809 This is B<NOT> a type system for Perl 5. These are type constraints,
 810 and they are not used by Moose unless you tell it to. No type
 811 inference is performed, expressions are not typed, etc. etc. etc.
 812
 813 A type constraint is at heart a small "check if a value is valid"
 814 function. A constraint can be associated with an attribute. This
 815 simplifies parameter validation, and makes your code clearer to read,
 816 because you can refer to constraints by name.
 817
 818 =head2 Slightly Less Important Caveat
 819
 820 It is B<always> a good idea to quote your type names.
 821
 822 This prevents Perl from trying to execute the call as an indirect
 823 object call. This can be an issue when you have a subtype with the
 824 same name as a valid class.
 825
 826 For instance:
 827
 828   subtype DateTime => as Object => where { $_->isa('DateTime') };
 829
 830 will I<just work>, while this:
 831
 832   use DateTime;
 833   subtype DateTime => as Object => where { $_->isa('DateTime') };
 834
 835 will fail silently and cause many headaches. The simple way to solve
 836 this, as well as future proof your subtypes from classes which have
 837 yet to have been created, is to quote the type name:
 838
 839   use DateTime;
 840   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 841
 842 =head2 Default Type Constraints
 843
 844 This module also provides a simple hierarchy for Perl 5 types, here is
 845 that hierarchy represented visually.
 846
 847   Any
 848   Item
 849       Bool
 850       Maybe[`a]
 851       Undef
 852       Defined
 853           Value
 854               Num
 855                 Int
 856               Str
 857                 ClassName
 858                 RoleName
 859           Ref
 860               ScalarRef
 861               ArrayRef[`a]
 862               HashRef[`a]
 863               CodeRef
 864               RegexpRef
 865               GlobRef
 866                 FileHandle
 867               Object
 868                 Role
 869
 870 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 871 parameterized, this means you can say:
 872
 873   ArrayRef[Int]    # an array of integers
 874   HashRef[CodeRef] # a hash of str to CODE ref mappings
 875   Maybe[Str]       # value may be a string, may be undefined
 876
 877 If Moose finds a name in brackets that it does not recognize as an
 878 existing type, it assumes that this is a class name, for example
 879 C<ArrayRef[DateTime]>.
 880
 881 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 882 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 883 name, I<not> as a parameterization of C<ArrayRef>.
 884
 885 B<NOTE:> The C<Undef> type constraint for the most part works
 886 correctly now, but edge cases may still exist, please use it
 887 sparingly.
 888
 889 B<NOTE:> The C<ClassName> type constraint does a complex package
 890 existence check. This means that your class B<must> be loaded for this
 891 type constraint to pass.
 892
 893 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 894 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 895 constraint checks that an I<object does> the named role.
 896
 897 =head2 Type Constraint Naming
 898
 899 Type name declared via this module can only contain alphanumeric
 900 characters, colons (:), and periods (.).
 901
 902 Since the types created by this module are global, it is suggested
 903 that you namespace your types just as you would namespace your
 904 modules. So instead of creating a I<Color> type for your
 905 B<My::Graphics> module, you would call the type
 906 I<My::Graphics::Types::Color> instead.
 907
 908 =head2 Use with Other Constraint Modules
 909
 910 This module can play nicely with other constraint modules with some
 911 slight tweaking. The C<where> clause in types is expected to be a
 912 C<CODE> reference which checks it's first argument and returns a
 913 boolean. Since most constraint modules work in a similar way, it
 914 should be simple to adapt them to work with Moose.
 915
 916 For instance, this is how you could use it with
 917 L<Declare::Constraints::Simple> to declare a completely new type.
 918
 919   type 'HashOfArrayOfObjects',
 920       {
 921       where => IsHashRef(
 922           -keys   => HasLength,
 923           -values => IsArrayRef(IsObject)
 924       )
 925   };
 926
 927 For more examples see the F<t/200_examples/004_example_w_DCS.t> test
 928 file.
 929
 930 Here is an example of using L<Test::Deep> and it's non-test
 931 related C<eq_deeply> function.
 932
 933   type 'ArrayOfHashOfBarsAndRandomNumbers'
 934       => where {
 935           eq_deeply($_,
 936               array_each(subhashof({
 937                   bar           => isa('Bar'),
 938                   random_number => ignore()
 939               })))
 940         };
 941
 942 For a complete example see the
 943 F<t/200_examples/005_example_w_TestDeep.t> test file.
 944
 945 =head1 FUNCTIONS
 946
 947 =head2 Type Constraint Constructors
 948
 949 The following functions are used to create type constraints.  They
 950 will also register the type constraints your create in a global
 951 registry that is used to look types up by name.
 952
 953 See the L<SYNOPSIS> for an example of how to use these.
 954
 955 =over 4
 956
 957 =item B<subtype 'Name' => as 'Parent' => where { } ...>
 958
 959 This creates a named subtype.
 960
 961 If you provide a parent that Moose does not recognize, it will
 962 automatically create a new class type constraint for this name.
 963
 964 When creating a named type, the C<subtype> function should either be
 965 called with the sugar helpers (C<where>, C<message>, etc), or with a
 966 name and a hashref of parameters:
 967
 968  subtype( 'Foo', { where => ..., message => ... } );
 969
 970 The valid hashref keys are C<as> (the parent), C<where>, C<message>,
 971 and C<optimize_as>.
 972
 973 =item B<subtype as 'Parent' => where { } ...>
 974
 975 This creates an unnamed subtype and will return the type
 976 constraint meta-object, which will be an instance of
 977 L<Moose::Meta::TypeConstraint>.
 978
 979 When creating an anonymous type, the C<subtype> function should either
 980 be called with the sugar helpers (C<where>, C<message>, etc), or with
 981 just a hashref of parameters:
 982
 983  subtype( { where => ..., message => ... } );
 984
 985 =item B<class_type ($class, ?$options)>
 986
 987 Creates a new subtype of C<Object> with the name C<$class> and the
 988 metaclass L<Moose::Meta::TypeConstraint::Class>.
 989
 990 =item B<role_type ($role, ?$options)>
 991
 992 Creates a C<Role> type constraint with the name C<$role> and the
 993 metaclass L<Moose::Meta::TypeConstraint::Role>.
 994
 995 =item B<maybe_type ($type)>
 996
 997 Creates a type constraint for either C<undef> or something of the
 998 given type.
 999
1000 =item B<duck_type ($name, @methods)>
1001
1002 This will create a subtype of Object and test to make sure the value
1003 C<can()> do the methods in C<@methods>.
1004
1005 This is intended as an easy way to accept non-Moose objects that
1006 provide a certain interface. If you're using Moose classes, we
1007 recommend that you use a C<requires>-only Role instead.
1008
1009 =item B<duck_type (\@methods)>
1010
1011 If passed an ARRAY reference instead of the C<$name>, C<@methods>
1012 pair, this will create an unnamed duck type. This can be used in an
1013 attribute definiton like so:
1014
1015   has 'cache' => (
1016       is  => 'ro',
1017       isa => duck_type( [qw( get_set )] ),
1018   );
1019
1020 =item B<enum ($name, @values)>
1021
1022 This will create a basic subtype for a given set of strings.
1023 The resulting constraint will be a subtype of C<Str> and
1024 will match any of the items in C<@values>. It is case sensitive.
1025 See the L<SYNOPSIS> for a simple example.
1026
1027 B<NOTE:> This is not a true proper enum type, it is simply
1028 a convenient constraint builder.
1029
1030 =item B<enum (\@values)>
1031
1032 If passed an ARRAY reference instead of the C<$name>, C<@values> pair,
1033 this will create an unnamed enum. This can then be used in an attribute
1034 definition like so:
1035
1036   has 'sort_order' => (
1037       is  => 'ro',
1038       isa => enum([qw[ ascending descending ]]),
1039   );
1040
1041 =item B<as 'Parent'>
1042
1043 This is just sugar for the type constraint construction syntax.
1044
1045 It takes a single argument, which is the name of a parent type.
1046
1047 =item B<where { ... }>
1048
1049 This is just sugar for the type constraint construction syntax.
1050
1051 It takes a subroutine reference as an argument. When the type
1052 constraint is tested, the reference is run with the value to be tested
1053 in C<$_>. This reference should return true or false to indicate
1054 whether or not the constraint check passed.
1055
1056 =item B<message { ... }>
1057
1058 This is just sugar for the type constraint construction syntax.
1059
1060 It takes a subroutine reference as an argument. When the type
1061 constraint fails, then the code block is run with the value provided
1062 in C<$_>. This reference should return a string, which will be used in
1063 the text of the exception thrown.
1064
1065 =item B<optimize_as { ... }>
1066
1067 This can be used to define a "hand optimized" version of your
1068 type constraint which can be used to avoid traversing a subtype
1069 constraint hierarchy.
1070
1071 B<NOTE:> You should only use this if you know what you are doing,
1072 all the built in types use this, so your subtypes (assuming they
1073 are shallow) will not likely need to use this.
1074
1075 =item B<type 'Name' => where { } ... >
1076
1077 This creates a base type, which has no parent.
1078
1079 The C<type> function should either be called with the sugar helpers
1080 (C<where>, C<message>, etc), or with a name and a hashref of
1081 parameters:
1082
1083   type( 'Foo', { where => ..., message => ... } );
1084
1085 The valid hashref keys are C<where>, C<message>, and C<optimize_as>.
1086
1087 =back
1088
1089 =head2 Type Coercion Constructors
1090
1091 You can define coercions for type constraints, which allow you to
1092 automatically transform values to something valid for the type
1093 constraint. If you ask your accessor to coerce, then Moose will run
1094 the type-coercion code first, followed by the type constraint
1095 check. This feature should be used carefully as it is very powerful
1096 and could easily take off a limb if you are not careful.
1097
1098 See the L<SYNOPSIS> for an example of how to use these.
1099
1100 =over 4
1101
1102 =item B<< coerce 'Name' => from 'OtherName' => via { ... } >>
1103
1104 This defines a coercion from one type to another. The C<Name> argument
1105 is the type you are coercing I<to>.
1106
1107 =item B<from 'OtherName'>
1108
1109 This is just sugar for the type coercion construction syntax.
1110
1111 It takes a single type name (or type object), which is the type being
1112 coerced I<from>.
1113
1114 =item B<via { ... }>
1115
1116 This is just sugar for the type coercion construction syntax.
1117
1118 It takes a subroutine reference. This reference will be called with
1119 the value to be coerced in C<$_>. It is expected to return a new value
1120 of the proper type for the coercion.
1121
1122 =back
1123
1124 =head2 Creating and Finding Type Constraints
1125
1126 These are additional functions for creating and finding type
1127 constraints. Most of these functions are not available for
1128 importing. The ones that are importable as specified.
1129
1130 =over 4
1131
1132 =item B<find_type_constraint($type_name)>
1133
1134 This function can be used to locate the L<Moose::Meta::TypeConstraint>
1135 object for a named type.
1136
1137 This function is importable.
1138
1139 =item B<register_type_constraint($type_object)>
1140
1141 This function will register a L<Moose::Meta::TypeConstraint> with the
1142 global type registry.
1143
1144 This function is importable.
1145
1146 =item B<normalize_type_constraint_name($type_constraint_name)>
1147
1148 This method takes a type constraint name and returns the normalized
1149 form. This removes any whitespace in the string.
1150
1151 =item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)>
1152
1153 This can take a union type specification like C<'Int|ArrayRef[Int]'>,
1154 or a list of names. It returns a new
1155 L<Moose::Meta::TypeConstraint::Union> object.
1156
1157 =item B<create_parameterized_type_constraint($type_name)>
1158
1159 Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>,
1160 this will create a new L<Moose::Meta::TypeConstraint::Parameterized>
1161 object. The C<BaseType> must exist already exist as a parameterizable
1162 type.
1163
1164 =item B<create_class_type_constraint($class, $options)>
1165
1166 Given a class name this function will create a new
1167 L<Moose::Meta::TypeConstraint::Class> object for that class name.
1168
1169 The C<$options> is a hash reference that will be passed to the
1170 L<Moose::Meta::TypeConstraint::Class> constructor (as a hash).
1171
1172 =item B<create_role_type_constraint($role, $options)>
1173
1174 Given a role name this function will create a new
1175 L<Moose::Meta::TypeConstraint::Role> object for that role name.
1176
1177 The C<$options> is a hash reference that will be passed to the
1178 L<Moose::Meta::TypeConstraint::Role> constructor (as a hash).
1179
1180 =item B<create_enum_type_constraint($name, $values)>
1181
1182 Given a enum name this function will create a new
1183 L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
1184
1185 =item B<find_or_parse_type_constraint($type_name)>
1186
1187 Given a type name, this first attempts to find a matching constraint
1188 in the global registry.
1189
1190 If the type name is a union or parameterized type, it will create a
1191 new object of the appropriate, but if given a "regular" type that does
1192 not yet exist, it simply returns false.
1193
1194 When given a union or parameterized type, the member or base type must
1195 already exist.
1196
1197 If it creates a new union or parameterized type, it will add it to the
1198 global registry.
1199
1200 =item B<find_or_create_isa_type_constraint($type_name)>
1201
1202 =item B<find_or_create_does_type_constraint($type_name)>
1203
1204 These functions will first call C<find_or_parse_type_constraint>. If
1205 that function does not return a type, a new anonymous type object will
1206 be created.
1207
1208 The C<isa> variant will use C<create_class_type_constraint> and the
1209 C<does> variant will use C<create_role_type_constraint>.
1210
1211 =item B<get_type_constraint_registry>
1212
1213 Returns the L<Moose::Meta::TypeConstraint::Registry> object which
1214 keeps track of all type constraints.
1215
1216 =item B<list_all_type_constraints>
1217
1218 This will return a list of type constraint names in the global
1219 registry. You can then fetch the actual type object using
1220 C<find_type_constraint($type_name)>.
1221
1222 =item B<list_all_builtin_type_constraints>
1223
1224 This will return a list of builtin type constraints, meaning those
1225 which are defined in this module. See the L<Default Type Constraints>
1226 section for a complete list.
1227
1228 =item B<export_type_constraints_as_functions>
1229
1230 This will export all the current type constraints as functions into
1231 the caller's namespace (C<Int()>, C<Str()>, etc). Right now, this is
1232 mostly used for testing, but it might prove useful to others.
1233
1234 =item B<get_all_parameterizable_types>
1235
1236 This returns all the parameterizable types that have been registered,
1237 as a list of type objects.
1238
1239 =item B<add_parameterizable_type($type)>
1240
1241 Adds C<$type> to the list of parameterizable types
1242
1243 =back
1244
1245 =head1 BUGS
1246
1247 All complex software has bugs lurking in it, and this module is no
1248 exception. If you find a bug please either email me, or add the bug
1249 to cpan-RT.
1250
1251 =head1 AUTHOR
1252
1253 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1254
1255 =head1 COPYRIGHT AND LICENSE
1256
1257 Copyright 2006-2009 by Infinity Interactive, Inc.
1258
1259 L<http://www.iinteractive.com>
1260
1261 This library is free software; you can redistribute it and/or modify
1262 it under the same terms as Perl itself.
1263
1264 =cut