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.79';
  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                 return 0 unless all { $obj->can($_) } @methods;
 375                 return 1;
 376             },
 377             sub {
 378                 my $obj = $_;
 379                 my @missing_methods = grep { !$obj->can($_) } @methods;
 380                 return
 381                     "${\blessed($obj)} is missing methods '@missing_methods'";
 382             },
 383         )
 384     );
 385 }
 386
 387 sub coerce {
 388     my ( $type_name, @coercion_map ) = @_;
 389     _install_type_coercions( $type_name, \@coercion_map );
 390 }
 391
 392 # The trick of returning @_ lets us avoid having to specify a
 393 # prototype. Perl will parse this:
 394 #
 395 # subtype 'Foo'
 396 #     => as 'Str'
 397 #     => where { ... }
 398 #
 399 # as this:
 400 #
 401 # subtype( 'Foo', as( 'Str', where { ... } ) );
 402 #
 403 # If as() returns all it's extra arguments, this just works, and
 404 # preserves backwards compatibility.
 405 sub as { { as => shift }, @_ }
 406 sub where (&)       { { where       => $_[0] } }
 407 sub message (&)     { { message     => $_[0] } }
 408 sub optimize_as (&) { { optimize_as => $_[0] } }
 409
 410 sub from    {@_}
 411 sub via (&) { $_[0] }
 412
 413 sub enum {
 414     my ( $type_name, @values ) = @_;
 415
 416     # NOTE:
 417     # if only an array-ref is passed then
 418     # you get an anon-enum
 419     # - SL
 420     if ( ref $type_name eq 'ARRAY' && !@values ) {
 421         @values    = @$type_name;
 422         $type_name = undef;
 423     }
 424     ( scalar @values >= 2 )
 425         || __PACKAGE__->_throw_error(
 426         "You must have at least two values to enumerate through");
 427     my %valid = map { $_ => 1 } @values;
 428
 429     register_type_constraint(
 430         create_enum_type_constraint(
 431             $type_name,
 432             \@values,
 433         )
 434     );
 435 }
 436
 437 sub create_enum_type_constraint {
 438     my ( $type_name, $values ) = @_;
 439
 440     Moose::Meta::TypeConstraint::Enum->new(
 441         name => $type_name || '__ANON__',
 442         values => $values,
 443     );
 444 }
 445
 446 ## --------------------------------------------------------
 447 ## desugaring functions ...
 448 ## --------------------------------------------------------
 449
 450 sub _create_type_constraint ($$$;$$) {
 451     my $name      = shift;
 452     my $parent    = shift;
 453     my $check     = shift;
 454     my $message   = shift;
 455     my $optimized = shift;
 456
 457     my $pkg_defined_in = scalar( caller(1) );
 458
 459     if ( defined $name ) {
 460         my $type = $REGISTRY->get_type_constraint($name);
 461
 462         ( $type->_package_defined_in eq $pkg_defined_in )
 463             || _confess(
 464                   "The type constraint '$name' has already been created in "
 465                 . $type->_package_defined_in
 466                 . " and cannot be created again in "
 467                 . $pkg_defined_in )
 468             if defined $type;
 469
 470         $name =~ /^[\w:\.]+$/
 471             or die qq{$name contains invalid characters for a type name.}
 472             . qq{ Names can contain alphanumeric character, ":", and "."\n};
 473     }
 474
 475     my %opts = (
 476         name               => $name,
 477         package_defined_in => $pkg_defined_in,
 478
 479         ( $check     ? ( constraint => $check )     : () ),
 480         ( $message   ? ( message    => $message )   : () ),
 481         ( $optimized ? ( optimized  => $optimized ) : () ),
 482     );
 483
 484     my $constraint;
 485     if (
 486         defined $parent
 487         and $parent
 488         = blessed $parent
 489         ? $parent
 490         : find_or_create_isa_type_constraint($parent)
 491         ) {
 492         $constraint = $parent->create_child_type(%opts);
 493     }
 494     else {
 495         $constraint = Moose::Meta::TypeConstraint->new(%opts);
 496     }
 497
 498     $REGISTRY->add_type_constraint($constraint)
 499         if defined $name;
 500
 501     return $constraint;
 502 }
 503
 504 sub _install_type_coercions ($$) {
 505     my ( $type_name, $coercion_map ) = @_;
 506     my $type = find_type_constraint($type_name);
 507     ( defined $type )
 508         || __PACKAGE__->_throw_error(
 509         "Cannot find type '$type_name', perhaps you forgot to load it.");
 510     if ( $type->has_coercion ) {
 511         $type->coercion->add_type_coercions(@$coercion_map);
 512     }
 513     else {
 514         my $type_coercion = Moose::Meta::TypeCoercion->new(
 515             type_coercion_map => $coercion_map,
 516             type_constraint   => $type
 517         );
 518         $type->coercion($type_coercion);
 519     }
 520 }
 521
 522 ## --------------------------------------------------------
 523 ## type notation parsing ...
 524 ## --------------------------------------------------------
 525
 526 {
 527
 528     # All I have to say is mugwump++ cause I know
 529     # do not even have enough regexp-fu to be able
 530     # to have written this (I can only barely
 531     # understand it as it is)
 532     # - SL
 533
 534     use re "eval";
 535
 536     my $valid_chars = qr{[\w:\.]};
 537     my $type_atom   = qr{ $valid_chars+ };
 538
 539     my $any;
 540
 541     my $type = qr{  $valid_chars+  (?: \[ \s* (??{$any})   \s* \] )? }x;
 542     my $type_capture_parts
 543         = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x;
 544     my $type_with_parameter
 545         = qr{  $valid_chars+      \[ \s* (??{$any})   \s* \]    }x;
 546
 547     my $op_union = qr{ \s* \| \s* }x;
 548     my $union    = qr{ $type (?: $op_union $type )+ }x;
 549
 550     $any = qr{ $type | $union }x;
 551
 552     sub _parse_parameterized_type_constraint {
 553         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 554         $_[0] =~ m{ $type_capture_parts }x;
 555         return ( $1, $2 );
 556     }
 557
 558     sub _detect_parameterized_type_constraint {
 559         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 560         $_[0] =~ m{ ^ $type_with_parameter $ }x;
 561     }
 562
 563     sub _parse_type_constraint_union {
 564         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 565         my $given = shift;
 566         my @rv;
 567         while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
 568             push @rv => $1;
 569         }
 570         ( pos($given) eq length($given) )
 571             || __PACKAGE__->_throw_error( "'$given' didn't parse (parse-pos="
 572                 . pos($given)
 573                 . " and str-length="
 574                 . length($given)
 575                 . ")" );
 576         @rv;
 577     }
 578
 579     sub _detect_type_constraint_union {
 580         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 581         $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
 582     }
 583 }
 584
 585 ## --------------------------------------------------------
 586 # define some basic built-in types
 587 ## --------------------------------------------------------
 588
 589 # By making these classes immutable before creating all the types we
 590 # below, we avoid repeatedly calling the slow MOP-based accessors.
 591 $_->make_immutable(
 592     inline_constructor => 1,
 593     constructor_name   => "_new",
 594
 595     # these are Class::MOP accessors, so they need inlining
 596     inline_accessors => 1
 597     ) for grep { $_->is_mutable }
 598     map { Class::MOP::class_of($_) }
 599     qw(
 600     Moose::Meta::TypeConstraint
 601     Moose::Meta::TypeConstraint::Union
 602     Moose::Meta::TypeConstraint::Parameterized
 603     Moose::Meta::TypeConstraint::Parameterizable
 604     Moose::Meta::TypeConstraint::Class
 605     Moose::Meta::TypeConstraint::Role
 606     Moose::Meta::TypeConstraint::Enum
 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 does> the named role.
 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<find_or_parse_type_constraint($type_name)>
1182
1183 Given a type name, this first attempts to find a matching constraint
1184 in the global registry.
1185
1186 If the type name is a union or parameterized type, it will create a
1187 new object of the appropriate, but if given a "regular" type that does
1188 not yet exist, it simply returns false.
1189
1190 When given a union or parameterized type, the member or base type must
1191 already exist.
1192
1193 If it creates a new union or parameterized type, it will add it to the
1194 global registry.
1195
1196 =item B<find_or_create_isa_type_constraint($type_name)>
1197
1198 =item B<find_or_create_does_type_constraint($type_name)>
1199
1200 These functions will first call C<find_or_parse_type_constraint>. If
1201 that function does not return a type, a new anonymous type object will
1202 be created.
1203
1204 The C<isa> variant will use C<create_class_type_constraint> and the
1205 C<does> variant will use C<create_role_type_constraint>.
1206
1207 =item B<get_type_constraint_registry>
1208
1209 Returns the L<Moose::Meta::TypeConstraint::Registry> object which
1210 keeps track of all type constraints.
1211
1212 =item B<list_all_type_constraints>
1213
1214 This will return a list of type constraint names in the global
1215 registry. You can then fetch the actual type object using
1216 C<find_type_constraint($type_name)>.
1217
1218 =item B<list_all_builtin_type_constraints>
1219
1220 This will return a list of builtin type constraints, meaning those
1221 which are defined in this module. See the L<Default Type Constraints>
1222 section for a complete list.
1223
1224 =item B<export_type_constraints_as_functions>
1225
1226 This will export all the current type constraints as functions into
1227 the caller's namespace (C<Int()>, C<Str()>, etc). Right now, this is
1228 mostly used for testing, but it might prove useful to others.
1229
1230 =item B<get_all_parameterizable_types>
1231
1232 This returns all the parameterizable types that have been registered,
1233 as a list of type objects.
1234
1235 =item B<add_parameterizable_type($type)>
1236
1237 Adds C<$type> to the list of parameterizable types
1238
1239 =back
1240
1241 =head1 BUGS
1242
1243 All complex software has bugs lurking in it, and this module is no
1244 exception. If you find a bug please either email me, or add the bug
1245 to cpan-RT.
1246
1247 =head1 AUTHOR
1248
1249 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1250
1251 =head1 COPYRIGHT AND LICENSE
1252
1253 Copyright 2006-2009 by Infinity Interactive, Inc.
1254
1255 L<http://www.iinteractive.com>
1256
1257 This library is free software; you can redistribute it and/or modify
1258 it under the same terms as Perl itself.
1259
1260 =cut