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::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 subtype 'Role' => as 'Object' => where { $_->can('does') } =>
 661     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role;
 662
 663 my $_class_name_checker = sub { };
 664
 665 subtype 'ClassName' => as 'Str' =>
 666     where { Class::MOP::is_class_loaded($_) } => optimize_as
 667     \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName;
 668
 669 subtype 'RoleName' => as 'ClassName' => where {
 670     (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role');
 671 } => optimize_as
 672     \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName;
 673
 674 ## --------------------------------------------------------
 675 # parameterizable types ...
 676
 677 $REGISTRY->add_type_constraint(
 678     Moose::Meta::TypeConstraint::Parameterizable->new(
 679         name               => 'ArrayRef',
 680         package_defined_in => __PACKAGE__,
 681         parent             => find_type_constraint('Ref'),
 682         constraint         => sub { ref($_) eq 'ARRAY' },
 683         optimized =>
 684             \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
 685         constraint_generator => sub {
 686             my $type_parameter = shift;
 687             my $check          = $type_parameter->_compiled_type_constraint;
 688             return sub {
 689                 foreach my $x (@$_) {
 690                     ( $check->($x) ) || return;
 691                 }
 692                 1;
 693                 }
 694         }
 695     )
 696 );
 697
 698 $REGISTRY->add_type_constraint(
 699     Moose::Meta::TypeConstraint::Parameterizable->new(
 700         name               => 'HashRef',
 701         package_defined_in => __PACKAGE__,
 702         parent             => find_type_constraint('Ref'),
 703         constraint         => sub { ref($_) eq 'HASH' },
 704         optimized =>
 705             \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
 706         constraint_generator => sub {
 707             my $type_parameter = shift;
 708             my $check          = $type_parameter->_compiled_type_constraint;
 709             return sub {
 710                 foreach my $x ( values %$_ ) {
 711                     ( $check->($x) ) || return;
 712                 }
 713                 1;
 714                 }
 715         }
 716     )
 717 );
 718
 719 $REGISTRY->add_type_constraint(
 720     Moose::Meta::TypeConstraint::Parameterizable->new(
 721         name                 => 'Maybe',
 722         package_defined_in   => __PACKAGE__,
 723         parent               => find_type_constraint('Item'),
 724         constraint           => sub {1},
 725         constraint_generator => sub {
 726             my $type_parameter = shift;
 727             my $check          = $type_parameter->_compiled_type_constraint;
 728             return sub {
 729                 return 1 if not( defined($_) ) || $check->($_);
 730                 return;
 731                 }
 732         }
 733     )
 734 );
 735
 736 my @PARAMETERIZABLE_TYPES
 737     = map { $REGISTRY->get_type_constraint($_) } qw[ArrayRef HashRef Maybe];
 738
 739 sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES}
 740
 741 sub add_parameterizable_type {
 742     my $type = shift;
 743     ( blessed $type
 744             && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') )
 745         || __PACKAGE__->_throw_error(
 746         "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type"
 747         );
 748     push @PARAMETERIZABLE_TYPES => $type;
 749 }
 750
 751 ## --------------------------------------------------------
 752 # end of built-in types ...
 753 ## --------------------------------------------------------
 754
 755 {
 756     my @BUILTINS = list_all_type_constraints();
 757     sub list_all_builtin_type_constraints {@BUILTINS}
 758 }
 759
 760 sub _throw_error {
 761     shift;
 762     require Moose;
 763     unshift @_, 'Moose';
 764     goto &Moose::throw_error;
 765 }
 766
 767 1;
 768
 769 __END__
 770
 771 =pod
 772
 773 =head1 NAME
 774
 775 Moose::Util::TypeConstraints - Type constraint system for Moose
 776
 777 =head1 SYNOPSIS
 778
 779   use Moose::Util::TypeConstraints;
 780
 781   subtype 'Natural'
 782       => as 'Int'
 783       => where { $_ > 0 };
 784
 785   subtype 'NaturalLessThanTen'
 786       => as 'Natural'
 787       => where { $_ < 10 }
 788       => message { "This number ($_) is not less than ten!" };
 789
 790   coerce 'Num'
 791       => from 'Str'
 792         => via { 0+$_ };
 793
 794   enum 'RGBColors' => qw(red green blue);
 795
 796   no Moose::Util::TypeConstraints;
 797
 798 =head1 DESCRIPTION
 799
 800 This module provides Moose with the ability to create custom type
 801 constraints to be used in attribute definition.
 802
 803 =head2 Important Caveat
 804
 805 This is B<NOT> a type system for Perl 5. These are type constraints,
 806 and they are not used by Moose unless you tell it to. No type
 807 inference is performed, expressions are not typed, etc. etc. etc.
 808
 809 A type constraint is at heart a small "check if a value is valid"
 810 function. A constraint can be associated with an attribute. This
 811 simplifies parameter validation, and makes your code clearer to read,
 812 because you can refer to constraints by name.
 813
 814 =head2 Slightly Less Important Caveat
 815
 816 It is B<always> a good idea to quote your type names.
 817
 818 This prevents Perl from trying to execute the call as an indirect
 819 object call. This can be an issue when you have a subtype with the
 820 same name as a valid class.
 821
 822 For instance:
 823
 824   subtype DateTime => as Object => where { $_->isa('DateTime') };
 825
 826 will I<just work>, while this:
 827
 828   use DateTime;
 829   subtype DateTime => as Object => where { $_->isa('DateTime') };
 830
 831 will fail silently and cause many headaches. The simple way to solve
 832 this, as well as future proof your subtypes from classes which have
 833 yet to have been created, is to quote the type name:
 834
 835   use DateTime;
 836   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 837
 838 =head2 Default Type Constraints
 839
 840 This module also provides a simple hierarchy for Perl 5 types, here is
 841 that hierarchy represented visually.
 842
 843   Any
 844   Item
 845       Bool
 846       Maybe[`a]
 847       Undef
 848       Defined
 849           Value
 850               Num
 851                   Int
 852               Str
 853                   ClassName
 854                   RoleName
 855           Ref
 856               ScalarRef
 857               ArrayRef[`a]
 858               HashRef[`a]
 859               CodeRef
 860               RegexpRef
 861               GlobRef
 862                   FileHandle
 863               Object
 864                   Role
 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'>. The C<Role>
 891 constraint checks that an I<object> has a C<does> method.
 892
 893 =head2 Type Constraint Naming
 894
 895 Type name declared via this module can only contain alphanumeric
 896 characters, colons (:), and periods (.).
 897
 898 Since the types created by this module are global, it is suggested
 899 that you namespace your types just as you would namespace your
 900 modules. So instead of creating a I<Color> type for your
 901 B<My::Graphics> module, you would call the type
 902 I<My::Graphics::Types::Color> instead.
 903
 904 =head2 Use with Other Constraint Modules
 905
 906 This module can play nicely with other constraint modules with some
 907 slight tweaking. The C<where> clause in types is expected to be a
 908 C<CODE> reference which checks it's first argument and returns a
 909 boolean. Since most constraint modules work in a similar way, it
 910 should be simple to adapt them to work with Moose.
 911
 912 For instance, this is how you could use it with
 913 L<Declare::Constraints::Simple> to declare a completely new type.
 914
 915   type 'HashOfArrayOfObjects',
 916       {
 917       where => IsHashRef(
 918           -keys   => HasLength,
 919           -values => IsArrayRef(IsObject)
 920       )
 921   };
 922
 923 For more examples see the F<t/200_examples/004_example_w_DCS.t> test
 924 file.
 925
 926 Here is an example of using L<Test::Deep> and it's non-test
 927 related C<eq_deeply> function.
 928
 929   type 'ArrayOfHashOfBarsAndRandomNumbers'
 930       => where {
 931           eq_deeply($_,
 932               array_each(subhashof({
 933                   bar           => isa('Bar'),
 934                   random_number => ignore()
 935               })))
 936         };
 937
 938 For a complete example see the
 939 F<t/200_examples/005_example_w_TestDeep.t> test file.
 940
 941 =head1 FUNCTIONS
 942
 943 =head2 Type Constraint Constructors
 944
 945 The following functions are used to create type constraints.  They
 946 will also register the type constraints your create in a global
 947 registry that is used to look types up by name.
 948
 949 See the L<SYNOPSIS> for an example of how to use these.
 950
 951 =over 4
 952
 953 =item B<< subtype 'Name' => as 'Parent' => where { } ... >>
 954
 955 This creates a named subtype.
 956
 957 If you provide a parent that Moose does not recognize, it will
 958 automatically create a new class type constraint for this name.
 959
 960 When creating a named type, the C<subtype> function should either be
 961 called with the sugar helpers (C<where>, C<message>, etc), or with a
 962 name and a hashref of parameters:
 963
 964  subtype( 'Foo', { where => ..., message => ... } );
 965
 966 The valid hashref keys are C<as> (the parent), C<where>, C<message>,
 967 and C<optimize_as>.
 968
 969 =item B<< subtype as 'Parent' => where { } ... >>
 970
 971 This creates an unnamed subtype and will return the type
 972 constraint meta-object, which will be an instance of
 973 L<Moose::Meta::TypeConstraint>.
 974
 975 When creating an anonymous type, the C<subtype> function should either
 976 be called with the sugar helpers (C<where>, C<message>, etc), or with
 977 just a hashref of parameters:
 978
 979  subtype( { where => ..., message => ... } );
 980
 981 =item B<class_type ($class, ?$options)>
 982
 983 Creates a new subtype of C<Object> with the name C<$class> and the
 984 metaclass L<Moose::Meta::TypeConstraint::Class>.
 985
 986 =item B<role_type ($role, ?$options)>
 987
 988 Creates a C<Role> type constraint with the name C<$role> and the
 989 metaclass L<Moose::Meta::TypeConstraint::Role>.
 990
 991 =item B<maybe_type ($type)>
 992
 993 Creates a type constraint for either C<undef> or something of the
 994 given type.
 995
 996 =item B<duck_type ($name, @methods)>
 997
 998 This will create a subtype of Object and test to make sure the value
 999 C<can()> do the methods in C<@methods>.
1000
1001 This is intended as an easy way to accept non-Moose objects that
1002 provide a certain interface. If you're using Moose classes, we
1003 recommend that you use a C<requires>-only Role instead.
1004
1005 =item B<duck_type (\@methods)>
1006
1007 If passed an ARRAY reference instead of the C<$name>, C<@methods>
1008 pair, this will create an unnamed duck type. This can be used in an
1009 attribute definition like so:
1010
1011   has 'cache' => (
1012       is  => 'ro',
1013       isa => duck_type( [qw( get_set )] ),
1014   );
1015
1016 =item B<enum ($name, @values)>
1017
1018 This will create a basic subtype for a given set of strings.
1019 The resulting constraint will be a subtype of C<Str> and
1020 will match any of the items in C<@values>. It is case sensitive.
1021 See the L<SYNOPSIS> for a simple example.
1022
1023 B<NOTE:> This is not a true proper enum type, it is simply
1024 a convenient constraint builder.
1025
1026 =item B<enum (\@values)>
1027
1028 If passed an ARRAY reference instead of the C<$name>, C<@values> pair,
1029 this will create an unnamed enum. This can then be used in an attribute
1030 definition like so:
1031
1032   has 'sort_order' => (
1033       is  => 'ro',
1034       isa => enum([qw[ ascending descending ]]),
1035   );
1036
1037 =item B<as 'Parent'>
1038
1039 This is just sugar for the type constraint construction syntax.
1040
1041 It takes a single argument, which is the name of a parent type.
1042
1043 =item B<where { ... }>
1044
1045 This is just sugar for the type constraint construction syntax.
1046
1047 It takes a subroutine reference as an argument. When the type
1048 constraint is tested, the reference is run with the value to be tested
1049 in C<$_>. This reference should return true or false to indicate
1050 whether or not the constraint check passed.
1051
1052 =item B<message { ... }>
1053
1054 This is just sugar for the type constraint construction syntax.
1055
1056 It takes a subroutine reference as an argument. When the type
1057 constraint fails, then the code block is run with the value provided
1058 in C<$_>. This reference should return a string, which will be used in
1059 the text of the exception thrown.
1060
1061 =item B<optimize_as { ... }>
1062
1063 This can be used to define a "hand optimized" version of your
1064 type constraint which can be used to avoid traversing a subtype
1065 constraint hierarchy.
1066
1067 B<NOTE:> You should only use this if you know what you are doing,
1068 all the built in types use this, so your subtypes (assuming they
1069 are shallow) will not likely need to use this.
1070
1071 =item B<type 'Name' => where { } ... >
1072
1073 This creates a base type, which has no parent.
1074
1075 The C<type> function should either be called with the sugar helpers
1076 (C<where>, C<message>, etc), or with a name and a hashref of
1077 parameters:
1078
1079   type( 'Foo', { where => ..., message => ... } );
1080
1081 The valid hashref keys are C<where>, C<message>, and C<optimize_as>.
1082
1083 =back
1084
1085 =head2 Type Coercion Constructors
1086
1087 You can define coercions for type constraints, which allow you to
1088 automatically transform values to something valid for the type
1089 constraint. If you ask your accessor to coerce, then Moose will run
1090 the type-coercion code first, followed by the type constraint
1091 check. This feature should be used carefully as it is very powerful
1092 and could easily take off a limb if you are not careful.
1093
1094 See the L<SYNOPSIS> for an example of how to use these.
1095
1096 =over 4
1097
1098 =item B<< coerce 'Name' => from 'OtherName' => via { ... } >>
1099
1100 This defines a coercion from one type to another. The C<Name> argument
1101 is the type you are coercing I<to>.
1102
1103 =item B<from 'OtherName'>
1104
1105 This is just sugar for the type coercion construction syntax.
1106
1107 It takes a single type name (or type object), which is the type being
1108 coerced I<from>.
1109
1110 =item B<via { ... }>
1111
1112 This is just sugar for the type coercion construction syntax.
1113
1114 It takes a subroutine reference. This reference will be called with
1115 the value to be coerced in C<$_>. It is expected to return a new value
1116 of the proper type for the coercion.
1117
1118 =back
1119
1120 =head2 Creating and Finding Type Constraints
1121
1122 These are additional functions for creating and finding type
1123 constraints. Most of these functions are not available for
1124 importing. The ones that are importable as specified.
1125
1126 =over 4
1127
1128 =item B<find_type_constraint($type_name)>
1129
1130 This function can be used to locate the L<Moose::Meta::TypeConstraint>
1131 object for a named type.
1132
1133 This function is importable.
1134
1135 =item B<register_type_constraint($type_object)>
1136
1137 This function will register a L<Moose::Meta::TypeConstraint> with the
1138 global type registry.
1139
1140 This function is importable.
1141
1142 =item B<normalize_type_constraint_name($type_constraint_name)>
1143
1144 This method takes a type constraint name and returns the normalized
1145 form. This removes any whitespace in the string.
1146
1147 =item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)>
1148
1149 This can take a union type specification like C<'Int|ArrayRef[Int]'>,
1150 or a list of names. It returns a new
1151 L<Moose::Meta::TypeConstraint::Union> object.
1152
1153 =item B<create_parameterized_type_constraint($type_name)>
1154
1155 Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>,
1156 this will create a new L<Moose::Meta::TypeConstraint::Parameterized>
1157 object. The C<BaseType> must exist already exist as a parameterizable
1158 type.
1159
1160 =item B<create_class_type_constraint($class, $options)>
1161
1162 Given a class name this function will create a new
1163 L<Moose::Meta::TypeConstraint::Class> object for that class name.
1164
1165 The C<$options> is a hash reference that will be passed to the
1166 L<Moose::Meta::TypeConstraint::Class> constructor (as a hash).
1167
1168 =item B<create_role_type_constraint($role, $options)>
1169
1170 Given a role name this function will create a new
1171 L<Moose::Meta::TypeConstraint::Role> object for that role name.
1172
1173 The C<$options> is a hash reference that will be passed to the
1174 L<Moose::Meta::TypeConstraint::Role> constructor (as a hash).
1175
1176 =item B<create_enum_type_constraint($name, $values)>
1177
1178 Given a enum name this function will create a new
1179 L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
1180
1181 =item B<create_duck_type_constraint($name, $methods)>
1182
1183 Given a duck type name this function will create a new
1184 L<Moose::Meta::TypeConstraint::DuckType> object for that enum name.
1185
1186 =item B<find_or_parse_type_constraint($type_name)>
1187
1188 Given a type name, this first attempts to find a matching constraint
1189 in the global registry.
1190
1191 If the type name is a union or parameterized type, it will create a
1192 new object of the appropriate, but if given a "regular" type that does
1193 not yet exist, it simply returns false.
1194
1195 When given a union or parameterized type, the member or base type must
1196 already exist.
1197
1198 If it creates a new union or parameterized type, it will add it to the
1199 global registry.
1200
1201 =item B<find_or_create_isa_type_constraint($type_name)>
1202
1203 =item B<find_or_create_does_type_constraint($type_name)>
1204
1205 These functions will first call C<find_or_parse_type_constraint>. If
1206 that function does not return a type, a new anonymous type object will
1207 be created.
1208
1209 The C<isa> variant will use C<create_class_type_constraint> and the
1210 C<does> variant will use C<create_role_type_constraint>.
1211
1212 =item B<get_type_constraint_registry>
1213
1214 Returns the L<Moose::Meta::TypeConstraint::Registry> object which
1215 keeps track of all type constraints.
1216
1217 =item B<list_all_type_constraints>
1218
1219 This will return a list of type constraint names in the global
1220 registry. You can then fetch the actual type object using
1221 C<find_type_constraint($type_name)>.
1222
1223 =item B<list_all_builtin_type_constraints>
1224
1225 This will return a list of builtin type constraints, meaning those
1226 which are defined in this module. See the L<Default Type Constraints>
1227 section for a complete list.
1228
1229 =item B<export_type_constraints_as_functions>
1230
1231 This will export all the current type constraints as functions into
1232 the caller's namespace (C<Int()>, C<Str()>, etc). Right now, this is
1233 mostly used for testing, but it might prove useful to others.
1234
1235 =item B<get_all_parameterizable_types>
1236
1237 This returns all the parameterizable types that have been registered,
1238 as a list of type objects.
1239
1240 =item B<add_parameterizable_type($type)>
1241
1242 Adds C<$type> to the list of parameterizable types
1243
1244 =back
1245
1246 =head1 BUGS
1247
1248 All complex software has bugs lurking in it, and this module is no
1249 exception. If you find a bug please either email me, or add the bug
1250 to cpan-RT.
1251
1252 =head1 AUTHOR
1253
1254 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1255
1256 =head1 COPYRIGHT AND LICENSE
1257
1258 Copyright 2006-2009 by Infinity Interactive, Inc.
1259
1260 L<http://www.iinteractive.com>
1261
1262 This library is free software; you can redistribute it and/or modify
1263 it under the same terms as Perl itself.
1264
1265 =cut