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