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.83';
  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::TypeCoercion;
  36 use Moose::Meta::TypeCoercion::Union;
  37 use Moose::Meta::TypeConstraint::Registry;
  38 use Moose::Util::TypeConstraints::OptimizedConstraints;
  39
  40 Moose::Exporter->setup_import_methods(
  41     as_is => [
  42         qw(
  43             type subtype class_type role_type maybe_type duck_type
  44             as where message optimize_as
  45             coerce from via
  46             enum
  47             find_type_constraint
  48             register_type_constraint )
  49     ],
  50     _export_to_main => 1,
  51 );
  52
  53 ## --------------------------------------------------------
  54 ## type registry and some useful functions for it
  55 ## --------------------------------------------------------
  56
  57 my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new;
  58
  59 sub get_type_constraint_registry {$REGISTRY}
  60 sub list_all_type_constraints    { keys %{ $REGISTRY->type_constraints } }
  61
  62 sub export_type_constraints_as_functions {
  63     my $pkg = caller();
  64     no strict 'refs';
  65     foreach my $constraint ( keys %{ $REGISTRY->type_constraints } ) {
  66         my $tc = $REGISTRY->get_type_constraint($constraint)
  67             ->_compiled_type_constraint;
  68         *{"${pkg}::${constraint}"}
  69             = sub { $tc->( $_[0] ) ? 1 : undef };    # the undef is for compat
  70     }
  71 }
  72
  73 sub create_type_constraint_union {
  74     my @type_constraint_names;
  75
  76     if ( scalar @_ == 1 && _detect_type_constraint_union( $_[0] ) ) {
  77         @type_constraint_names = _parse_type_constraint_union( $_[0] );
  78     }
  79     else {
  80         @type_constraint_names = @_;
  81     }
  82
  83     ( scalar @type_constraint_names >= 2 )
  84         || __PACKAGE__->_throw_error(
  85         "You must pass in at least 2 type names to make a union");
  86
  87     my @type_constraints = map {
  88         find_or_parse_type_constraint($_)
  89             || __PACKAGE__->_throw_error(
  90             "Could not locate type constraint ($_) for the union");
  91     } @type_constraint_names;
  92
  93     return Moose::Meta::TypeConstraint::Union->new(
  94         type_constraints => \@type_constraints );
  95 }
  96
  97 sub create_parameterized_type_constraint {
  98     my $type_constraint_name = shift;
  99     my ( $base_type, $type_parameter )
 100         = _parse_parameterized_type_constraint($type_constraint_name);
 101
 102     ( defined $base_type && defined $type_parameter )
 103         || __PACKAGE__->_throw_error(
 104         "Could not parse type name ($type_constraint_name) correctly");
 105
 106     if ( $REGISTRY->has_type_constraint($base_type) ) {
 107         my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
 108         return _create_parameterized_type_constraint(
 109             $base_type_tc,
 110             $type_parameter
 111         );
 112     }
 113     else {
 114         __PACKAGE__->_throw_error(
 115             "Could not locate the base type ($base_type)");
 116     }
 117 }
 118
 119 sub _create_parameterized_type_constraint {
 120     my ( $base_type_tc, $type_parameter ) = @_;
 121     if ( $base_type_tc->can('parameterize') ) {
 122         return $base_type_tc->parameterize($type_parameter);
 123     }
 124     else {
 125         return Moose::Meta::TypeConstraint::Parameterized->new(
 126             name   => $base_type_tc->name . '[' . $type_parameter . ']',
 127             parent => $base_type_tc,
 128             type_parameter =>
 129                 find_or_create_isa_type_constraint($type_parameter),
 130         );
 131     }
 132 }
 133
 134 #should we also support optimized checks?
 135 sub create_class_type_constraint {
 136     my ( $class, $options ) = @_;
 137
 138 # too early for this check
 139 #find_type_constraint("ClassName")->check($class)
 140 #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
 141
 142     my %options = (
 143         class => $class,
 144         name  => $class,
 145         %{ $options || {} },
 146     );
 147
 148     $options{name} ||= "__ANON__";
 149
 150     Moose::Meta::TypeConstraint::Class->new(%options);
 151 }
 152
 153 sub create_role_type_constraint {
 154     my ( $role, $options ) = @_;
 155
 156 # too early for this check
 157 #find_type_constraint("ClassName")->check($class)
 158 #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
 159
 160     my %options = (
 161         role => $role,
 162         name => $role,
 163         %{ $options || {} },
 164     );
 165
 166     $options{name} ||= "__ANON__";
 167
 168     Moose::Meta::TypeConstraint::Role->new(%options);
 169 }
 170
 171 sub find_or_create_type_constraint {
 172     my ( $type_constraint_name, $options_for_anon_type ) = @_;
 173
 174     if ( my $constraint
 175         = find_or_parse_type_constraint($type_constraint_name) ) {
 176         return $constraint;
 177     }
 178     elsif ( defined $options_for_anon_type ) {
 179
 180         # NOTE:
 181         # if there is no $options_for_anon_type
 182         # specified, then we assume they don't
 183         # want to create one, and return nothing.
 184
 185         # otherwise assume that we should create
 186         # an ANON type with the $options_for_anon_type
 187         # options which can be passed in. It should
 188         # be noted that these don't get registered
 189         # so we need to return it.
 190         # - SL
 191         return Moose::Meta::TypeConstraint->new(
 192             name => '__ANON__',
 193             %{$options_for_anon_type}
 194         );
 195     }
 196
 197     return;
 198 }
 199
 200 sub find_or_create_isa_type_constraint {
 201     my $type_constraint_name = shift;
 202     find_or_parse_type_constraint($type_constraint_name)
 203         || create_class_type_constraint($type_constraint_name);
 204 }
 205
 206 sub find_or_create_does_type_constraint {
 207     my $type_constraint_name = shift;
 208     find_or_parse_type_constraint($type_constraint_name)
 209         || create_role_type_constraint($type_constraint_name);
 210 }
 211
 212 sub find_or_parse_type_constraint {
 213     my $type_constraint_name = normalize_type_constraint_name(shift);
 214     my $constraint;
 215
 216     if ( $constraint = find_type_constraint($type_constraint_name) ) {
 217         return $constraint;
 218     }
 219     elsif ( _detect_type_constraint_union($type_constraint_name) ) {
 220         $constraint = create_type_constraint_union($type_constraint_name);
 221     }
 222     elsif ( _detect_parameterized_type_constraint($type_constraint_name) ) {
 223         $constraint
 224             = create_parameterized_type_constraint($type_constraint_name);
 225     }
 226     else {
 227         return;
 228     }
 229
 230     $REGISTRY->add_type_constraint($constraint);
 231     return $constraint;
 232 }
 233
 234 sub normalize_type_constraint_name {
 235     my $type_constraint_name = shift;
 236     $type_constraint_name =~ s/\s//g;
 237     return $type_constraint_name;
 238 }
 239
 240 sub _confess {
 241     my $error = shift;
 242
 243     local $Carp::CarpLevel = $Carp::CarpLevel + 1;
 244     Carp::confess($error);
 245 }
 246
 247 ## --------------------------------------------------------
 248 ## exported functions ...
 249 ## --------------------------------------------------------
 250
 251 sub find_type_constraint {
 252     my $type = shift;
 253
 254     if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) {
 255         return $type;
 256     }
 257     else {
 258         return unless $REGISTRY->has_type_constraint($type);
 259         return $REGISTRY->get_type_constraint($type);
 260     }
 261 }
 262
 263 sub register_type_constraint {
 264     my $constraint = shift;
 265     __PACKAGE__->_throw_error("can't register an unnamed type constraint")
 266         unless defined $constraint->name;
 267     $REGISTRY->add_type_constraint($constraint);
 268     return $constraint;
 269 }
 270
 271 # type constructors
 272
 273 sub type {
 274
 275     # back-compat version, called without sugar
 276     if ( !any { ( reftype($_) || '' ) eq 'HASH' } @_ ) {
 277         return _create_type_constraint( $_[0], undef, $_[1] );
 278     }
 279
 280     my $name = shift;
 281
 282     my %p = map { %{$_} } @_;
 283
 284     return _create_type_constraint(
 285         $name, undef, $p{where}, $p{message},
 286         $p{optimize_as}
 287     );
 288 }
 289
 290 sub subtype {
 291
 292     # crazy back-compat code for being called without sugar ...
 293     #
 294     # subtype 'Parent', sub { where };
 295     if ( scalar @_ == 2 && ( reftype( $_[1] ) || '' ) eq 'CODE' ) {
 296         return _create_type_constraint( undef, @_ );
 297     }
 298
 299     # subtype 'Parent', sub { where }, sub { message };
 300     # subtype 'Parent', sub { where }, sub { message }, sub { optimized };
 301     if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' }
 302         @_[ 1 .. $#_ ] ) {
 303         return _create_type_constraint( undef, @_ );
 304     }
 305
 306     # subtype 'Name', 'Parent', ...
 307     if ( scalar @_ >= 2 && all { !ref } @_[ 0, 1 ] ) {
 308         return _create_type_constraint(@_);
 309     }
 310
 311     if ( @_ == 1 && !ref $_[0] ) {
 312         __PACKAGE__->_throw_error(
 313             'A subtype cannot consist solely of a name, it must have a parent'
 314         );
 315     }
 316
 317     # The blessed check is mostly to accommodate MooseX::Types, which
 318     # uses an object which overloads stringification as a type name.
 319     my $name = ref $_[0] && !blessed $_[0] ? undef : shift;
 320
 321     my %p = map { %{$_} } @_;
 322
 323     # subtype Str => where { ... };
 324     if ( !exists $p{as} ) {
 325         $p{as} = $name;
 326         $name = undef;
 327     }
 328
 329     return _create_type_constraint(
 330         $name, $p{as}, $p{where}, $p{message},
 331         $p{optimize_as}
 332     );
 333 }
 334
 335 sub class_type {
 336     register_type_constraint(
 337         create_class_type_constraint(
 338             $_[0],
 339             ( defined( $_[1] ) ? $_[1] : () ),
 340         )
 341     );
 342 }
 343
 344 sub role_type ($;$) {
 345     register_type_constraint(
 346         create_role_type_constraint(
 347             $_[0],
 348             ( defined( $_[1] ) ? $_[1] : () ),
 349         )
 350     );
 351 }
 352
 353 sub maybe_type {
 354     my ($type_parameter) = @_;
 355
 356     register_type_constraint(
 357         $REGISTRY->get_type_constraint('Maybe')->parameterize($type_parameter)
 358     );
 359 }
 360
 361 sub duck_type {
 362     my ( $type_name, @methods ) = @_;
 363     if ( ref $type_name eq 'ARRAY' && !@methods ) {
 364         @methods   = @$type_name;
 365         $type_name = undef;
 366     }
 367
 368     register_type_constraint(
 369         _create_type_constraint(
 370             $type_name,
 371             'Object',
 372             sub {
 373                 my $obj = $_;
 374                 my $class = blessed($obj) || return;
 375                 return 0 unless all { $obj->can($_) } @methods;
 376                 return 1;
 377             },
 378             sub {
 379                 my $obj = $_;
 380                 my $class = blessed($obj);
 381                 my @missing_methods = grep { !$obj->can($_) } @methods;
 382                 return
 383                     "$class 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 { Class::MOP::class_of($_) }
 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 subtype 'Item' => as 'Any';  # 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 'Str' =>
 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     (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role');
 673 } => optimize_as
 674     \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName;
 675
 676 ## --------------------------------------------------------
 677 # parameterizable types ...
 678
 679 $REGISTRY->add_type_constraint(
 680     Moose::Meta::TypeConstraint::Parameterizable->new(
 681         name               => 'ArrayRef',
 682         package_defined_in => __PACKAGE__,
 683         parent             => find_type_constraint('Ref'),
 684         constraint         => sub { ref($_) eq 'ARRAY' },
 685         optimized =>
 686             \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
 687         constraint_generator => sub {
 688             my $type_parameter = shift;
 689             my $check          = $type_parameter->_compiled_type_constraint;
 690             return sub {
 691                 foreach my $x (@$_) {
 692                     ( $check->($x) ) || return;
 693                 }
 694                 1;
 695                 }
 696         }
 697     )
 698 );
 699
 700 $REGISTRY->add_type_constraint(
 701     Moose::Meta::TypeConstraint::Parameterizable->new(
 702         name               => 'HashRef',
 703         package_defined_in => __PACKAGE__,
 704         parent             => find_type_constraint('Ref'),
 705         constraint         => sub { ref($_) eq 'HASH' },
 706         optimized =>
 707             \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
 708         constraint_generator => sub {
 709             my $type_parameter = shift;
 710             my $check          = $type_parameter->_compiled_type_constraint;
 711             return sub {
 712                 foreach my $x ( values %$_ ) {
 713                     ( $check->($x) ) || return;
 714                 }
 715                 1;
 716                 }
 717         }
 718     )
 719 );
 720
 721 $REGISTRY->add_type_constraint(
 722     Moose::Meta::TypeConstraint::Parameterizable->new(
 723         name                 => 'Maybe',
 724         package_defined_in   => __PACKAGE__,
 725         parent               => find_type_constraint('Item'),
 726         constraint           => sub {1},
 727         constraint_generator => sub {
 728             my $type_parameter = shift;
 729             my $check          = $type_parameter->_compiled_type_constraint;
 730             return sub {
 731                 return 1 if not( defined($_) ) || $check->($_);
 732                 return;
 733                 }
 734         }
 735     )
 736 );
 737
 738 my @PARAMETERIZABLE_TYPES
 739     = map { $REGISTRY->get_type_constraint($_) } qw[ArrayRef HashRef Maybe];
 740
 741 sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES}
 742
 743 sub add_parameterizable_type {
 744     my $type = shift;
 745     ( blessed $type
 746             && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') )
 747         || __PACKAGE__->_throw_error(
 748         "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type"
 749         );
 750     push @PARAMETERIZABLE_TYPES => $type;
 751 }
 752
 753 ## --------------------------------------------------------
 754 # end of built-in types ...
 755 ## --------------------------------------------------------
 756
 757 {
 758     my @BUILTINS = list_all_type_constraints();
 759     sub list_all_builtin_type_constraints {@BUILTINS}
 760 }
 761
 762 sub _throw_error {
 763     shift;
 764     require Moose;
 765     unshift @_, 'Moose';
 766     goto &Moose::throw_error;
 767 }
 768
 769 1;
 770
 771 __END__
 772
 773 =pod
 774
 775 =head1 NAME
 776
 777 Moose::Util::TypeConstraints - Type constraint system for Moose
 778
 779 =head1 SYNOPSIS
 780
 781   use Moose::Util::TypeConstraints;
 782
 783   subtype 'Natural'
 784       => as 'Int'
 785       => where { $_ > 0 };
 786
 787   subtype 'NaturalLessThanTen'
 788       => as 'Natural'
 789       => where { $_ < 10 }
 790       => message { "This number ($_) is not less than ten!" };
 791
 792   coerce 'Num'
 793       => from 'Str'
 794         => via { 0+$_ };
 795
 796   enum 'RGBColors' => qw(red green blue);
 797
 798   no Moose::Util::TypeConstraints;
 799
 800 =head1 DESCRIPTION
 801
 802 This module provides Moose with the ability to create custom type
 803 constraints to be used in attribute definition.
 804
 805 =head2 Important Caveat
 806
 807 This is B<NOT> a type system for Perl 5. These are type constraints,
 808 and they are not used by Moose unless you tell it to. No type
 809 inference is performed, expressions are not typed, etc. etc. etc.
 810
 811 A type constraint is at heart a small "check if a value is valid"
 812 function. A constraint can be associated with an attribute. This
 813 simplifies parameter validation, and makes your code clearer to read,
 814 because you can refer to constraints by name.
 815
 816 =head2 Slightly Less Important Caveat
 817
 818 It is B<always> a good idea to quote your type names.
 819
 820 This prevents Perl from trying to execute the call as an indirect
 821 object call. This can be an issue when you have a subtype with the
 822 same name as a valid class.
 823
 824 For instance:
 825
 826   subtype DateTime => as Object => where { $_->isa('DateTime') };
 827
 828 will I<just work>, while this:
 829
 830   use DateTime;
 831   subtype DateTime => as Object => where { $_->isa('DateTime') };
 832
 833 will fail silently and cause many headaches. The simple way to solve
 834 this, as well as future proof your subtypes from classes which have
 835 yet to have been created, is to quote the type name:
 836
 837   use DateTime;
 838   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 839
 840 =head2 Default Type Constraints
 841
 842 This module also provides a simple hierarchy for Perl 5 types, here is
 843 that hierarchy represented visually.
 844
 845   Any
 846   Item
 847       Bool
 848       Maybe[`a]
 849       Undef
 850       Defined
 851           Value
 852               Num
 853                 Int
 854               Str
 855                 ClassName
 856                 RoleName
 857           Ref
 858               ScalarRef
 859               ArrayRef[`a]
 860               HashRef[`a]
 861               CodeRef
 862               RegexpRef
 863               GlobRef
 864                 FileHandle
 865               Object
 866                 Role
 867
 868 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 869 parameterized, this means you can say:
 870
 871   ArrayRef[Int]    # an array of integers
 872   HashRef[CodeRef] # a hash of str to CODE ref mappings
 873   Maybe[Str]       # value may be a string, may be undefined
 874
 875 If Moose finds a name in brackets that it does not recognize as an
 876 existing type, it assumes that this is a class name, for example
 877 C<ArrayRef[DateTime]>.
 878
 879 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 880 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 881 name, I<not> as a parameterization of C<ArrayRef>.
 882
 883 B<NOTE:> The C<Undef> type constraint for the most part works
 884 correctly now, but edge cases may still exist, please use it
 885 sparingly.
 886
 887 B<NOTE:> The C<ClassName> type constraint does a complex package
 888 existence check. This means that your class B<must> be loaded for this
 889 type constraint to pass.
 890
 891 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 892 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 893 constraint checks that an I<object does> the named role.
 894
 895 =head2 Type Constraint Naming
 896
 897 Type name declared via this module can only contain alphanumeric
 898 characters, colons (:), and periods (.).
 899
 900 Since the types created by this module are global, it is suggested
 901 that you namespace your types just as you would namespace your
 902 modules. So instead of creating a I<Color> type for your
 903 B<My::Graphics> module, you would call the type
 904 I<My::Graphics::Types::Color> instead.
 905
 906 =head2 Use with Other Constraint Modules
 907
 908 This module can play nicely with other constraint modules with some
 909 slight tweaking. The C<where> clause in types is expected to be a
 910 C<CODE> reference which checks it's first argument and returns a
 911 boolean. Since most constraint modules work in a similar way, it
 912 should be simple to adapt them to work with Moose.
 913
 914 For instance, this is how you could use it with
 915 L<Declare::Constraints::Simple> to declare a completely new type.
 916
 917   type 'HashOfArrayOfObjects',
 918       {
 919       where => IsHashRef(
 920           -keys   => HasLength,
 921           -values => IsArrayRef(IsObject)
 922       )
 923   };
 924
 925 For more examples see the F<t/200_examples/004_example_w_DCS.t> test
 926 file.
 927
 928 Here is an example of using L<Test::Deep> and it's non-test
 929 related C<eq_deeply> function.
 930
 931   type 'ArrayOfHashOfBarsAndRandomNumbers'
 932       => where {
 933           eq_deeply($_,
 934               array_each(subhashof({
 935                   bar           => isa('Bar'),
 936                   random_number => ignore()
 937               })))
 938         };
 939
 940 For a complete example see the
 941 F<t/200_examples/005_example_w_TestDeep.t> test file.
 942
 943 =head1 FUNCTIONS
 944
 945 =head2 Type Constraint Constructors
 946
 947 The following functions are used to create type constraints.  They
 948 will also register the type constraints your create in a global
 949 registry that is used to look types up by name.
 950
 951 See the L<SYNOPSIS> for an example of how to use these.
 952
 953 =over 4
 954
 955 =item B<< subtype 'Name' => as 'Parent' => where { } ... >>
 956
 957 This creates a named subtype.
 958
 959 If you provide a parent that Moose does not recognize, it will
 960 automatically create a new class type constraint for this name.
 961
 962 When creating a named type, the C<subtype> function should either be
 963 called with the sugar helpers (C<where>, C<message>, etc), or with a
 964 name and a hashref of parameters:
 965
 966  subtype( 'Foo', { where => ..., message => ... } );
 967
 968 The valid hashref keys are C<as> (the parent), C<where>, C<message>,
 969 and C<optimize_as>.
 970
 971 =item B<< subtype as 'Parent' => where { } ... >>
 972
 973 This creates an unnamed subtype and will return the type
 974 constraint meta-object, which will be an instance of
 975 L<Moose::Meta::TypeConstraint>.
 976
 977 When creating an anonymous type, the C<subtype> function should either
 978 be called with the sugar helpers (C<where>, C<message>, etc), or with
 979 just a hashref of parameters:
 980
 981  subtype( { where => ..., message => ... } );
 982
 983 =item B<class_type ($class, ?$options)>
 984
 985 Creates a new subtype of C<Object> with the name C<$class> and the
 986 metaclass L<Moose::Meta::TypeConstraint::Class>.
 987
 988 =item B<role_type ($role, ?$options)>
 989
 990 Creates a C<Role> type constraint with the name C<$role> and the
 991 metaclass L<Moose::Meta::TypeConstraint::Role>.
 992
 993 =item B<maybe_type ($type)>
 994
 995 Creates a type constraint for either C<undef> or something of the
 996 given type.
 997
 998 =item B<duck_type ($name, @methods)>
 999
1000 This will create a subtype of Object and test to make sure the value
1001 C<can()> do the methods in C<@methods>.
1002
1003 This is intended as an easy way to accept non-Moose objects that
1004 provide a certain interface. If you're using Moose classes, we
1005 recommend that you use a C<requires>-only Role instead.
1006
1007 =item B<duck_type (\@methods)>
1008
1009 If passed an ARRAY reference instead of the C<$name>, C<@methods>
1010 pair, this will create an unnamed duck type. This can be used in an
1011 attribute definition like so:
1012
1013   has 'cache' => (
1014       is  => 'ro',
1015       isa => duck_type( [qw( get_set )] ),
1016   );
1017
1018 =item B<enum ($name, @values)>
1019
1020 This will create a basic subtype for a given set of strings.
1021 The resulting constraint will be a subtype of C<Str> and
1022 will match any of the items in C<@values>. It is case sensitive.
1023 See the L<SYNOPSIS> for a simple example.
1024
1025 B<NOTE:> This is not a true proper enum type, it is simply
1026 a convenient constraint builder.
1027
1028 =item B<enum (\@values)>
1029
1030 If passed an ARRAY reference instead of the C<$name>, C<@values> pair,
1031 this will create an unnamed enum. This can then be used in an attribute
1032 definition like so:
1033
1034   has 'sort_order' => (
1035       is  => 'ro',
1036       isa => enum([qw[ ascending descending ]]),
1037   );
1038
1039 =item B<as 'Parent'>
1040
1041 This is just sugar for the type constraint construction syntax.
1042
1043 It takes a single argument, which is the name of a parent type.
1044
1045 =item B<where { ... }>
1046
1047 This is just sugar for the type constraint construction syntax.
1048
1049 It takes a subroutine reference as an argument. When the type
1050 constraint is tested, the reference is run with the value to be tested
1051 in C<$_>. This reference should return true or false to indicate
1052 whether or not the constraint check passed.
1053
1054 =item B<message { ... }>
1055
1056 This is just sugar for the type constraint construction syntax.
1057
1058 It takes a subroutine reference as an argument. When the type
1059 constraint fails, then the code block is run with the value provided
1060 in C<$_>. This reference should return a string, which will be used in
1061 the text of the exception thrown.
1062
1063 =item B<optimize_as { ... }>
1064
1065 This can be used to define a "hand optimized" version of your
1066 type constraint which can be used to avoid traversing a subtype
1067 constraint hierarchy.
1068
1069 B<NOTE:> You should only use this if you know what you are doing,
1070 all the built in types use this, so your subtypes (assuming they
1071 are shallow) will not likely need to use this.
1072
1073 =item B<type 'Name' => where { } ... >
1074
1075 This creates a base type, which has no parent.
1076
1077 The C<type> function should either be called with the sugar helpers
1078 (C<where>, C<message>, etc), or with a name and a hashref of
1079 parameters:
1080
1081   type( 'Foo', { where => ..., message => ... } );
1082
1083 The valid hashref keys are C<where>, C<message>, and C<optimize_as>.
1084
1085 =back
1086
1087 =head2 Type Coercion Constructors
1088
1089 You can define coercions for type constraints, which allow you to
1090 automatically transform values to something valid for the type
1091 constraint. If you ask your accessor to coerce, then Moose will run
1092 the type-coercion code first, followed by the type constraint
1093 check. This feature should be used carefully as it is very powerful
1094 and could easily take off a limb if you are not careful.
1095
1096 See the L<SYNOPSIS> for an example of how to use these.
1097
1098 =over 4
1099
1100 =item B<< coerce 'Name' => from 'OtherName' => via { ... } >>
1101
1102 This defines a coercion from one type to another. The C<Name> argument
1103 is the type you are coercing I<to>.
1104
1105 =item B<from 'OtherName'>
1106
1107 This is just sugar for the type coercion construction syntax.
1108
1109 It takes a single type name (or type object), which is the type being
1110 coerced I<from>.
1111
1112 =item B<via { ... }>
1113
1114 This is just sugar for the type coercion construction syntax.
1115
1116 It takes a subroutine reference. This reference will be called with
1117 the value to be coerced in C<$_>. It is expected to return a new value
1118 of the proper type for the coercion.
1119
1120 =back
1121
1122 =head2 Creating and Finding Type Constraints
1123
1124 These are additional functions for creating and finding type
1125 constraints. Most of these functions are not available for
1126 importing. The ones that are importable as specified.
1127
1128 =over 4
1129
1130 =item B<find_type_constraint($type_name)>
1131
1132 This function can be used to locate the L<Moose::Meta::TypeConstraint>
1133 object for a named type.
1134
1135 This function is importable.
1136
1137 =item B<register_type_constraint($type_object)>
1138
1139 This function will register a L<Moose::Meta::TypeConstraint> with the
1140 global type registry.
1141
1142 This function is importable.
1143
1144 =item B<normalize_type_constraint_name($type_constraint_name)>
1145
1146 This method takes a type constraint name and returns the normalized
1147 form. This removes any whitespace in the string.
1148
1149 =item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)>
1150
1151 This can take a union type specification like C<'Int|ArrayRef[Int]'>,
1152 or a list of names. It returns a new
1153 L<Moose::Meta::TypeConstraint::Union> object.
1154
1155 =item B<create_parameterized_type_constraint($type_name)>
1156
1157 Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>,
1158 this will create a new L<Moose::Meta::TypeConstraint::Parameterized>
1159 object. The C<BaseType> must exist already exist as a parameterizable
1160 type.
1161
1162 =item B<create_class_type_constraint($class, $options)>
1163
1164 Given a class name this function will create a new
1165 L<Moose::Meta::TypeConstraint::Class> object for that class name.
1166
1167 The C<$options> is a hash reference that will be passed to the
1168 L<Moose::Meta::TypeConstraint::Class> constructor (as a hash).
1169
1170 =item B<create_role_type_constraint($role, $options)>
1171
1172 Given a role name this function will create a new
1173 L<Moose::Meta::TypeConstraint::Role> object for that role name.
1174
1175 The C<$options> is a hash reference that will be passed to the
1176 L<Moose::Meta::TypeConstraint::Role> constructor (as a hash).
1177
1178 =item B<create_enum_type_constraint($name, $values)>
1179
1180 Given a enum name this function will create a new
1181 L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
1182
1183 =item B<find_or_parse_type_constraint($type_name)>
1184
1185 Given a type name, this first attempts to find a matching constraint
1186 in the global registry.
1187
1188 If the type name is a union or parameterized type, it will create a
1189 new object of the appropriate, but if given a "regular" type that does
1190 not yet exist, it simply returns false.
1191
1192 When given a union or parameterized type, the member or base type must
1193 already exist.
1194
1195 If it creates a new union or parameterized type, it will add it to the
1196 global registry.
1197
1198 =item B<find_or_create_isa_type_constraint($type_name)>
1199
1200 =item B<find_or_create_does_type_constraint($type_name)>
1201
1202 These functions will first call C<find_or_parse_type_constraint>. If
1203 that function does not return a type, a new anonymous type object will
1204 be created.
1205
1206 The C<isa> variant will use C<create_class_type_constraint> and the
1207 C<does> variant will use C<create_role_type_constraint>.
1208
1209 =item B<get_type_constraint_registry>
1210
1211 Returns the L<Moose::Meta::TypeConstraint::Registry> object which
1212 keeps track of all type constraints.
1213
1214 =item B<list_all_type_constraints>
1215
1216 This will return a list of type constraint names in the global
1217 registry. You can then fetch the actual type object using
1218 C<find_type_constraint($type_name)>.
1219
1220 =item B<list_all_builtin_type_constraints>
1221
1222 This will return a list of builtin type constraints, meaning those
1223 which are defined in this module. See the L<Default Type Constraints>
1224 section for a complete list.
1225
1226 =item B<export_type_constraints_as_functions>
1227
1228 This will export all the current type constraints as functions into
1229 the caller's namespace (C<Int()>, C<Str()>, etc). Right now, this is
1230 mostly used for testing, but it might prove useful to others.
1231
1232 =item B<get_all_parameterizable_types>
1233
1234 This returns all the parameterizable types that have been registered,
1235 as a list of type objects.
1236
1237 =item B<add_parameterizable_type($type)>
1238
1239 Adds C<$type> to the list of parameterizable types
1240
1241 =back
1242
1243 =head1 BUGS
1244
1245 All complex software has bugs lurking in it, and this module is no
1246 exception. If you find a bug please either email me, or add the bug
1247 to cpan-RT.
1248
1249 =head1 AUTHOR
1250
1251 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1252
1253 =head1 COPYRIGHT AND LICENSE
1254
1255 Copyright 2006-2009 by Infinity Interactive, Inc.
1256
1257 L<http://www.iinteractive.com>
1258
1259 This library is free software; you can redistribute it and/or modify
1260 it under the same terms as Perl itself.
1261
1262 =cut