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 ## --------------------------------------------------------
  10 # Prototyped subs must be predeclared because we have a
  11 # circular dependency with Moose::Meta::Attribute et. al.
  12 # so in case of us being use'd first the predeclaration
  13 # ensures the prototypes are in scope when consumers are
  14 # compiled.
  15
  16 # dah sugah!
  17 sub where (&);
  18 sub via (&);
  19 sub message (&);
  20 sub optimize_as (&);
  21
  22 ## --------------------------------------------------------
  23
  24 use Moose::Deprecated;
  25 use Moose::Meta::TypeConstraint;
  26 use Moose::Meta::TypeConstraint::Union;
  27 use Moose::Meta::TypeConstraint::Parameterized;
  28 use Moose::Meta::TypeConstraint::Parameterizable;
  29 use Moose::Meta::TypeConstraint::Class;
  30 use Moose::Meta::TypeConstraint::Role;
  31 use Moose::Meta::TypeConstraint::Enum;
  32 use Moose::Meta::TypeConstraint::DuckType;
  33 use Moose::Meta::TypeCoercion;
  34 use Moose::Meta::TypeCoercion::Union;
  35 use Moose::Meta::TypeConstraint::Registry;
  36
  37 Moose::Exporter->setup_import_methods(
  38     as_is => [
  39         qw(
  40             type subtype class_type role_type maybe_type duck_type
  41             as where message optimize_as
  42             coerce from via
  43             enum
  44             find_type_constraint
  45             register_type_constraint
  46             match_on_type )
  47     ],
  48 );
  49
  50 ## --------------------------------------------------------
  51 ## type registry and some useful functions for it
  52 ## --------------------------------------------------------
  53
  54 my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new;
  55
  56 sub get_type_constraint_registry {$REGISTRY}
  57 sub list_all_type_constraints    { keys %{ $REGISTRY->type_constraints } }
  58
  59 sub export_type_constraints_as_functions {
  60     my $pkg = caller();
  61     no strict 'refs';
  62     foreach my $constraint ( keys %{ $REGISTRY->type_constraints } ) {
  63         my $tc = $REGISTRY->get_type_constraint($constraint)
  64             ->_compiled_type_constraint;
  65         *{"${pkg}::${constraint}"}
  66             = sub { $tc->( $_[0] ) ? 1 : undef };    # the undef is for compat
  67     }
  68 }
  69
  70 sub create_type_constraint_union {
  71     my @type_constraint_names;
  72
  73     if ( scalar @_ == 1 && _detect_type_constraint_union( $_[0] ) ) {
  74         @type_constraint_names = _parse_type_constraint_union( $_[0] );
  75     }
  76     else {
  77         @type_constraint_names = @_;
  78     }
  79
  80     ( scalar @type_constraint_names >= 2 )
  81         || __PACKAGE__->_throw_error(
  82         "You must pass in at least 2 type names to make a union");
  83
  84     my @type_constraints = map {
  85         find_or_parse_type_constraint($_)
  86             || __PACKAGE__->_throw_error(
  87             "Could not locate type constraint ($_) for the union");
  88     } @type_constraint_names;
  89
  90     return Moose::Meta::TypeConstraint::Union->new(
  91         type_constraints => \@type_constraints );
  92 }
  93
  94 sub create_parameterized_type_constraint {
  95     my $type_constraint_name = shift;
  96     my ( $base_type, $type_parameter )
  97         = _parse_parameterized_type_constraint($type_constraint_name);
  98
  99     ( defined $base_type && defined $type_parameter )
 100         || __PACKAGE__->_throw_error(
 101         "Could not parse type name ($type_constraint_name) correctly");
 102
 103     if ( $REGISTRY->has_type_constraint($base_type) ) {
 104         my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
 105         return _create_parameterized_type_constraint(
 106             $base_type_tc,
 107             $type_parameter
 108         );
 109     }
 110     else {
 111         __PACKAGE__->_throw_error(
 112             "Could not locate the base type ($base_type)");
 113     }
 114 }
 115
 116 sub _create_parameterized_type_constraint {
 117     my ( $base_type_tc, $type_parameter ) = @_;
 118     if ( $base_type_tc->can('parameterize') ) {
 119         return $base_type_tc->parameterize($type_parameter);
 120     }
 121     else {
 122         return Moose::Meta::TypeConstraint::Parameterized->new(
 123             name   => $base_type_tc->name . '[' . $type_parameter . ']',
 124             parent => $base_type_tc,
 125             type_parameter =>
 126                 find_or_create_isa_type_constraint($type_parameter),
 127         );
 128     }
 129 }
 130
 131 #should we also support optimized checks?
 132 sub create_class_type_constraint {
 133     my ( $class, $options ) = @_;
 134
 135 # too early for this check
 136 #find_type_constraint("ClassName")->check($class)
 137 #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
 138
 139     my %options = (
 140         class => $class,
 141         name  => $class,
 142         %{ $options || {} },
 143     );
 144
 145     $options{name} ||= "__ANON__";
 146
 147     Moose::Meta::TypeConstraint::Class->new(%options);
 148 }
 149
 150 sub create_role_type_constraint {
 151     my ( $role, $options ) = @_;
 152
 153 # too early for this check
 154 #find_type_constraint("ClassName")->check($class)
 155 #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
 156
 157     my %options = (
 158         role => $role,
 159         name => $role,
 160         %{ $options || {} },
 161     );
 162
 163     $options{name} ||= "__ANON__";
 164
 165     Moose::Meta::TypeConstraint::Role->new(%options);
 166 }
 167
 168 sub find_or_create_type_constraint {
 169     my ( $type_constraint_name, $options_for_anon_type ) = @_;
 170
 171     if ( my $constraint
 172         = find_or_parse_type_constraint($type_constraint_name) ) {
 173         return $constraint;
 174     }
 175     elsif ( defined $options_for_anon_type ) {
 176
 177         # NOTE:
 178         # if there is no $options_for_anon_type
 179         # specified, then we assume they don't
 180         # want to create one, and return nothing.
 181
 182         # otherwise assume that we should create
 183         # an ANON type with the $options_for_anon_type
 184         # options which can be passed in. It should
 185         # be noted that these don't get registered
 186         # so we need to return it.
 187         # - SL
 188         return Moose::Meta::TypeConstraint->new(
 189             name => '__ANON__',
 190             %{$options_for_anon_type}
 191         );
 192     }
 193
 194     return;
 195 }
 196
 197 sub find_or_create_isa_type_constraint {
 198     my $type_constraint_name = shift;
 199     find_or_parse_type_constraint($type_constraint_name)
 200         || create_class_type_constraint($type_constraint_name);
 201 }
 202
 203 sub find_or_create_does_type_constraint {
 204     my $type_constraint_name = shift;
 205     find_or_parse_type_constraint($type_constraint_name)
 206         || create_role_type_constraint($type_constraint_name);
 207 }
 208
 209 sub find_or_parse_type_constraint {
 210     my $type_constraint_name = normalize_type_constraint_name(shift);
 211     my $constraint;
 212
 213     if ( $constraint = find_type_constraint($type_constraint_name) ) {
 214         return $constraint;
 215     }
 216     elsif ( _detect_type_constraint_union($type_constraint_name) ) {
 217         $constraint = create_type_constraint_union($type_constraint_name);
 218     }
 219     elsif ( _detect_parameterized_type_constraint($type_constraint_name) ) {
 220         $constraint
 221             = create_parameterized_type_constraint($type_constraint_name);
 222     }
 223     else {
 224         return;
 225     }
 226
 227     $REGISTRY->add_type_constraint($constraint);
 228     return $constraint;
 229 }
 230
 231 sub normalize_type_constraint_name {
 232     my $type_constraint_name = shift;
 233     $type_constraint_name =~ s/\s//g;
 234     return $type_constraint_name;
 235 }
 236
 237 sub _confess {
 238     my $error = shift;
 239
 240     local $Carp::CarpLevel = $Carp::CarpLevel + 1;
 241     Carp::confess($error);
 242 }
 243
 244 ## --------------------------------------------------------
 245 ## exported functions ...
 246 ## --------------------------------------------------------
 247
 248 sub find_type_constraint {
 249     my $type = shift;
 250
 251     if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) {
 252         return $type;
 253     }
 254     else {
 255         return unless $REGISTRY->has_type_constraint($type);
 256         return $REGISTRY->get_type_constraint($type);
 257     }
 258 }
 259
 260 sub register_type_constraint {
 261     my $constraint = shift;
 262     __PACKAGE__->_throw_error("can't register an unnamed type constraint")
 263         unless defined $constraint->name;
 264     $REGISTRY->add_type_constraint($constraint);
 265     return $constraint;
 266 }
 267
 268 # type constructors
 269
 270 sub type {
 271
 272     # back-compat version, called without sugar
 273     if ( !any { ( reftype($_) || '' ) eq 'HASH' } @_ ) {
 274         Moose::Deprecated::deprecated(
 275             feature => 'type without sugar',
 276             message =>
 277                 'Calling type() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
 278         );
 279
 280         return _create_type_constraint( $_[0], undef, $_[1] );
 281     }
 282
 283     my $name = shift;
 284
 285     my %p = map { %{$_} } @_;
 286
 287     return _create_type_constraint(
 288         $name, undef, $p{where}, $p{message},
 289         $p{optimize_as}
 290     );
 291 }
 292
 293 sub subtype {
 294
 295     # crazy back-compat code for being called without sugar ...
 296     #
 297     # subtype 'Parent', sub { where };
 298     if ( scalar @_ == 2 && ( reftype( $_[1] ) || '' ) eq 'CODE' ) {
 299         Moose::Deprecated::deprecated(
 300             feature => 'subtype without sugar',
 301             message =>
 302                 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
 303         );
 304
 305         return _create_type_constraint( undef, @_ );
 306     }
 307
 308     # subtype 'Parent', sub { where }, sub { message };
 309     # subtype 'Parent', sub { where }, sub { message }, sub { optimized };
 310     if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' }
 311         @_[ 1 .. $#_ ] ) {
 312         Moose::Deprecated::deprecated(
 313             feature => 'subtype without sugar',
 314             message =>
 315                 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
 316         );
 317
 318         return _create_type_constraint( undef, @_ );
 319     }
 320
 321     # subtype 'Name', 'Parent', ...
 322     if ( scalar @_ >= 2 && all { !ref } @_[ 0, 1 ] ) {
 323         Moose::Deprecated::deprecated(
 324             feature => 'subtype without sugar',
 325             message =>
 326                 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
 327         );
 328
 329         return _create_type_constraint(@_);
 330     }
 331
 332     if ( @_ == 1 && !ref $_[0] ) {
 333         __PACKAGE__->_throw_error(
 334             'A subtype cannot consist solely of a name, it must have a parent'
 335         );
 336     }
 337
 338     # The blessed check is mostly to accommodate MooseX::Types, which
 339     # uses an object which overloads stringification as a type name.
 340     my $name = ref $_[0] && !blessed $_[0] ? undef : shift;
 341
 342     my %p = map { %{$_} } @_;
 343
 344     # subtype Str => where { ... };
 345     if ( !exists $p{as} ) {
 346         $p{as} = $name;
 347         $name = undef;
 348     }
 349
 350     return _create_type_constraint(
 351         $name, $p{as}, $p{where}, $p{message},
 352         $p{optimize_as}
 353     );
 354 }
 355
 356 sub class_type {
 357     register_type_constraint(
 358         create_class_type_constraint(
 359             $_[0],
 360             ( defined( $_[1] ) ? $_[1] : () ),
 361         )
 362     );
 363 }
 364
 365 sub role_type ($;$) {
 366     register_type_constraint(
 367         create_role_type_constraint(
 368             $_[0],
 369             ( defined( $_[1] ) ? $_[1] : () ),
 370         )
 371     );
 372 }
 373
 374 sub maybe_type {
 375     my ($type_parameter) = @_;
 376
 377     register_type_constraint(
 378         $REGISTRY->get_type_constraint('Maybe')->parameterize($type_parameter)
 379     );
 380 }
 381
 382 sub duck_type {
 383     my ( $type_name, @methods ) = @_;
 384     if ( ref $type_name eq 'ARRAY' && !@methods ) {
 385         @methods   = @$type_name;
 386         $type_name = undef;
 387     }
 388     if ( @methods == 1 && ref $methods[0] eq 'ARRAY' ) {
 389         @methods = @{ $methods[0] };
 390     }
 391
 392     register_type_constraint(
 393         create_duck_type_constraint(
 394             $type_name,
 395             \@methods,
 396         )
 397     );
 398 }
 399
 400 sub coerce {
 401     my ( $type_name, @coercion_map ) = @_;
 402     _install_type_coercions( $type_name, \@coercion_map );
 403 }
 404
 405 # The trick of returning @_ lets us avoid having to specify a
 406 # prototype. Perl will parse this:
 407 #
 408 # subtype 'Foo'
 409 #     => as 'Str'
 410 #     => where { ... }
 411 #
 412 # as this:
 413 #
 414 # subtype( 'Foo', as( 'Str', where { ... } ) );
 415 #
 416 # If as() returns all its extra arguments, this just works, and
 417 # preserves backwards compatibility.
 418 sub as { { as => shift }, @_ }
 419 sub where (&)       { { where       => $_[0] } }
 420 sub message (&)     { { message     => $_[0] } }
 421 sub optimize_as (&) { { optimize_as => $_[0] } }
 422
 423 sub from    {@_}
 424 sub via (&) { $_[0] }
 425
 426 sub enum {
 427     my ( $type_name, @values ) = @_;
 428
 429     # NOTE:
 430     # if only an array-ref is passed then
 431     # you get an anon-enum
 432     # - SL
 433     if ( ref $type_name eq 'ARRAY' ) {
 434         @values == 0
 435             || __PACKAGE__->_throw_error("enum called with an array reference and additional arguments. Did you mean to parenthesize the enum call's parameters?");
 436
 437         @values    = @$type_name;
 438         $type_name = undef;
 439     }
 440     if ( @values == 1 && ref $values[0] eq 'ARRAY' ) {
 441         @values = @{ $values[0] };
 442     }
 443
 444     register_type_constraint(
 445         create_enum_type_constraint(
 446             $type_name,
 447             \@values,
 448         )
 449     );
 450 }
 451
 452 sub create_enum_type_constraint {
 453     my ( $type_name, $values ) = @_;
 454
 455     Moose::Meta::TypeConstraint::Enum->new(
 456         name => $type_name || '__ANON__',
 457         values => $values,
 458     );
 459 }
 460
 461 sub create_duck_type_constraint {
 462     my ( $type_name, $methods ) = @_;
 463
 464     Moose::Meta::TypeConstraint::DuckType->new(
 465         name => $type_name || '__ANON__',
 466         methods => $methods,
 467     );
 468 }
 469
 470 sub match_on_type {
 471     my ($to_match, @cases) = @_;
 472     my $default;
 473     if (@cases % 2 != 0) {
 474         $default = pop @cases;
 475         (ref $default eq 'CODE')
 476             || __PACKAGE__->_throw_error("Default case must be a CODE ref, not $default");
 477     }
 478     while (@cases) {
 479         my ($type, $action) = splice @cases, 0, 2;
 480
 481         unless (blessed $type && $type->isa('Moose::Meta::TypeConstraint')) {
 482             $type = find_or_parse_type_constraint($type)
 483                  || __PACKAGE__->_throw_error("Cannot find or parse the type '$type'")
 484         }
 485
 486         (ref $action eq 'CODE')
 487             || __PACKAGE__->_throw_error("Match action must be a CODE ref, not $action");
 488
 489         if ($type->check($to_match)) {
 490             local $_ = $to_match;
 491             return $action->($to_match);
 492         }
 493     }
 494     (defined $default)
 495         || __PACKAGE__->_throw_error("No cases matched for $to_match");
 496     {
 497         local $_ = $to_match;
 498         return $default->($to_match);
 499     }
 500 }
 501
 502
 503 ## --------------------------------------------------------
 504 ## desugaring functions ...
 505 ## --------------------------------------------------------
 506
 507 sub _create_type_constraint ($$$;$$) {
 508     my $name      = shift;
 509     my $parent    = shift;
 510     my $check     = shift;
 511     my $message   = shift;
 512     my $optimized = shift;
 513
 514     my $pkg_defined_in = scalar( caller(1) );
 515
 516     if ( defined $name ) {
 517         my $type = $REGISTRY->get_type_constraint($name);
 518
 519         ( $type->_package_defined_in eq $pkg_defined_in )
 520             || _confess(
 521                   "The type constraint '$name' has already been created in "
 522                 . $type->_package_defined_in
 523                 . " and cannot be created again in "
 524                 . $pkg_defined_in )
 525             if defined $type;
 526
 527         $name =~ /^[\w:\.]+$/
 528             or die qq{$name contains invalid characters for a type name.}
 529             . qq{ Names can contain alphanumeric character, ":", and "."\n};
 530     }
 531
 532     my %opts = (
 533         name               => $name,
 534         package_defined_in => $pkg_defined_in,
 535
 536         ( $check     ? ( constraint => $check )     : () ),
 537         ( $message   ? ( message    => $message )   : () ),
 538         ( $optimized ? ( optimized  => $optimized ) : () ),
 539     );
 540
 541     my $constraint;
 542     if (
 543         defined $parent
 544         and $parent
 545         = blessed $parent
 546         ? $parent
 547         : find_or_create_isa_type_constraint($parent)
 548         ) {
 549         $constraint = $parent->create_child_type(%opts);
 550     }
 551     else {
 552         $constraint = Moose::Meta::TypeConstraint->new(%opts);
 553     }
 554
 555     $REGISTRY->add_type_constraint($constraint)
 556         if defined $name;
 557
 558     return $constraint;
 559 }
 560
 561 sub _install_type_coercions ($$) {
 562     my ( $type_name, $coercion_map ) = @_;
 563     my $type = find_type_constraint($type_name);
 564     ( defined $type )
 565         || __PACKAGE__->_throw_error(
 566         "Cannot find type '$type_name', perhaps you forgot to load it");
 567     if ( $type->has_coercion ) {
 568         $type->coercion->add_type_coercions(@$coercion_map);
 569     }
 570     else {
 571         my $type_coercion = Moose::Meta::TypeCoercion->new(
 572             type_coercion_map => $coercion_map,
 573             type_constraint   => $type
 574         );
 575         $type->coercion($type_coercion);
 576     }
 577 }
 578
 579 ## --------------------------------------------------------
 580 ## type notation parsing ...
 581 ## --------------------------------------------------------
 582
 583 {
 584
 585     # All I have to say is mugwump++ cause I know
 586     # do not even have enough regexp-fu to be able
 587     # to have written this (I can only barely
 588     # understand it as it is)
 589     # - SL
 590
 591     use re "eval";
 592
 593     my $valid_chars = qr{[\w:\.]};
 594     my $type_atom   = qr{ (?>$valid_chars+) }x;
 595     my $ws          = qr{ (?>\s*) }x;
 596     my $op_union    = qr{ $ws \| $ws }x;
 597
 598     my ($type, $type_capture_parts, $type_with_parameter, $union, $any);
 599     if (Class::MOP::IS_RUNNING_ON_5_10) {
 600         my $type_pattern
 601             = q{  (?&type_atom)  (?: \[ (?&ws)  (?&any)  (?&ws) \] )? };
 602         my $type_capture_parts_pattern
 603             = q{ ((?&type_atom)) (?: \[ (?&ws) ((?&any)) (?&ws) \] )? };
 604         my $type_with_parameter_pattern
 605             = q{  (?&type_atom)      \[ (?&ws)  (?&any)  (?&ws) \]    };
 606         my $union_pattern
 607             = q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) };
 608         my $any_pattern
 609             = q{ (?&type) | (?&union) };
 610
 611         my $defines = qr{(?(DEFINE)
 612             (?<valid_chars>         $valid_chars)
 613             (?<type_atom>           $type_atom)
 614             (?<ws>                  $ws)
 615             (?<op_union>            $op_union)
 616             (?<type>                $type_pattern)
 617             (?<type_capture_parts>  $type_capture_parts_pattern)
 618             (?<type_with_parameter> $type_with_parameter_pattern)
 619             (?<union>               $union_pattern)
 620             (?<any>                 $any_pattern)
 621         )}x;
 622
 623         $type                = qr{ $type_pattern                $defines }x;
 624         $type_capture_parts  = qr{ $type_capture_parts_pattern  $defines }x;
 625         $type_with_parameter = qr{ $type_with_parameter_pattern $defines }x;
 626         $union               = qr{ $union_pattern               $defines }x;
 627         $any                 = qr{ $any_pattern                 $defines }x;
 628     }
 629     else {
 630         $type
 631             = qr{  $type_atom  (?: \[ $ws  (??{$any})  $ws \] )? }x;
 632         $type_capture_parts
 633             = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x;
 634         $type_with_parameter
 635             = qr{  $type_atom      \[ $ws  (??{$any})  $ws \]    }x;
 636         $union
 637             = qr{ $type (?> (?: $op_union $type )+ ) }x;
 638         $any
 639             = qr{ $type | $union }x;
 640     }
 641
 642
 643     sub _parse_parameterized_type_constraint {
 644         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 645         $_[0] =~ m{ $type_capture_parts }x;
 646         return ( $1, $2 );
 647     }
 648
 649     sub _detect_parameterized_type_constraint {
 650         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 651         $_[0] =~ m{ ^ $type_with_parameter $ }x;
 652     }
 653
 654     sub _parse_type_constraint_union {
 655         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 656         my $given = shift;
 657         my @rv;
 658         while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
 659             push @rv => $1;
 660         }
 661         ( pos($given) eq length($given) )
 662             || __PACKAGE__->_throw_error( "'$given' didn't parse (parse-pos="
 663                 . pos($given)
 664                 . " and str-length="
 665                 . length($given)
 666                 . ")" );
 667         @rv;
 668     }
 669
 670     sub _detect_type_constraint_union {
 671         { no warnings 'void'; $any; }  # force capture of interpolated lexical
 672         $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
 673     }
 674 }
 675
 676 ## --------------------------------------------------------
 677 # define some basic built-in types
 678 ## --------------------------------------------------------
 679
 680 # By making these classes immutable before creating all the types in
 681 # Moose::Util::TypeConstraints::Builtin , we avoid repeatedly calling the slow
 682 # MOP-based accessors.
 683 $_->make_immutable(
 684     inline_constructor => 1,
 685     constructor_name   => "_new",
 686
 687     # these are Class::MOP accessors, so they need inlining
 688     inline_accessors => 1
 689     ) for grep { $_->is_mutable }
 690     map { Class::MOP::class_of($_) }
 691     qw(
 692     Moose::Meta::TypeConstraint
 693     Moose::Meta::TypeConstraint::Union
 694     Moose::Meta::TypeConstraint::Parameterized
 695     Moose::Meta::TypeConstraint::Parameterizable
 696     Moose::Meta::TypeConstraint::Class
 697     Moose::Meta::TypeConstraint::Role
 698     Moose::Meta::TypeConstraint::Enum
 699     Moose::Meta::TypeConstraint::DuckType
 700     Moose::Meta::TypeConstraint::Registry
 701 );
 702
 703 require Moose::Util::TypeConstraints::Builtins;
 704 Moose::Util::TypeConstraints::Builtins::define_builtins($REGISTRY);
 705
 706 my @PARAMETERIZABLE_TYPES
 707     = map { $REGISTRY->get_type_constraint($_) } qw[ScalarRef ArrayRef HashRef Maybe];
 708
 709 sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES}
 710
 711 sub add_parameterizable_type {
 712     my $type = shift;
 713     ( blessed $type
 714             && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') )
 715         || __PACKAGE__->_throw_error(
 716         "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type"
 717         );
 718     push @PARAMETERIZABLE_TYPES => $type;
 719 }
 720
 721 ## --------------------------------------------------------
 722 # end of built-in types ...
 723 ## --------------------------------------------------------
 724
 725 {
 726     my @BUILTINS = list_all_type_constraints();
 727     sub list_all_builtin_type_constraints {@BUILTINS}
 728 }
 729
 730 sub _throw_error {
 731     shift;
 732     require Moose;
 733     unshift @_, 'Moose';
 734     goto &Moose::throw_error;
 735 }
 736
 737 1;
 738
 739 # ABSTRACT: Type constraint system for Moose
 740
 741 __END__
 742
 743 =pod
 744
 745 =head1 SYNOPSIS
 746
 747   use Moose::Util::TypeConstraints;
 748
 749   subtype 'Natural',
 750       as 'Int',
 751       where { $_ > 0 };
 752
 753   subtype 'NaturalLessThanTen',
 754       as 'Natural',
 755       where { $_ < 10 },
 756       message { "This number ($_) is not less than ten!" };
 757
 758   coerce 'Num',
 759       from 'Str',
 760       via { 0+$_ };
 761
 762   enum 'RGBColors', [qw(red green blue)];
 763
 764   no Moose::Util::TypeConstraints;
 765
 766 =head1 DESCRIPTION
 767
 768 This module provides Moose with the ability to create custom type
 769 constraints to be used in attribute definition.
 770
 771 =head2 Important Caveat
 772
 773 This is B<NOT> a type system for Perl 5. These are type constraints,
 774 and they are not used by Moose unless you tell it to. No type
 775 inference is performed, expressions are not typed, etc. etc. etc.
 776
 777 A type constraint is at heart a small "check if a value is valid"
 778 function. A constraint can be associated with an attribute. This
 779 simplifies parameter validation, and makes your code clearer to read,
 780 because you can refer to constraints by name.
 781
 782 =head2 Slightly Less Important Caveat
 783
 784 It is B<always> a good idea to quote your type names.
 785
 786 This prevents Perl from trying to execute the call as an indirect
 787 object call. This can be an issue when you have a subtype with the
 788 same name as a valid class.
 789
 790 For instance:
 791
 792   subtype DateTime => as Object => where { $_->isa('DateTime') };
 793
 794 will I<just work>, while this:
 795
 796   use DateTime;
 797   subtype DateTime => as Object => where { $_->isa('DateTime') };
 798
 799 will fail silently and cause many headaches. The simple way to solve
 800 this, as well as future proof your subtypes from classes which have
 801 yet to have been created, is to quote the type name:
 802
 803   use DateTime;
 804   subtype 'DateTime', as 'Object', where { $_->isa('DateTime') };
 805
 806 =head2 Default Type Constraints
 807
 808 This module also provides a simple hierarchy for Perl 5 types, here is
 809 that hierarchy represented visually.
 810
 811   Any
 812   Item
 813       Bool
 814       Maybe[`a]
 815       Undef
 816       Defined
 817           Value
 818               Str
 819                   Num
 820                       Int
 821                   ClassName
 822                   RoleName
 823           Ref
 824               ScalarRef[`a]
 825               ArrayRef[`a]
 826               HashRef[`a]
 827               CodeRef
 828               RegexpRef
 829               GlobRef
 830                   FileHandle
 831               Object
 832
 833 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 834 parameterized, this means you can say:
 835
 836   ArrayRef[Int]    # an array of integers
 837   HashRef[CodeRef] # a hash of str to CODE ref mappings
 838   ScalarRef[Int]   # a reference to an integer
 839   Maybe[Str]       # value may be a string, may be undefined
 840
 841 If Moose finds a name in brackets that it does not recognize as an
 842 existing type, it assumes that this is a class name, for example
 843 C<ArrayRef[DateTime]>.
 844
 845 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 846 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 847 name, I<not> as a parameterization of C<ArrayRef>.
 848
 849 B<NOTE:> The C<Undef> type constraint for the most part works
 850 correctly now, but edge cases may still exist, please use it
 851 sparingly.
 852
 853 B<NOTE:> The C<ClassName> type constraint does a complex package
 854 existence check. This means that your class B<must> be loaded for this
 855 type constraint to pass.
 856
 857 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 858 name> which is a role, like C<'MyApp::Role::Comparable'>.
 859
 860 =head2 Type Constraint Naming
 861
 862 Type name declared via this module can only contain alphanumeric
 863 characters, colons (:), and periods (.).
 864
 865 Since the types created by this module are global, it is suggested
 866 that you namespace your types just as you would namespace your
 867 modules. So instead of creating a I<Color> type for your
 868 B<My::Graphics> module, you would call the type
 869 I<My::Graphics::Types::Color> instead.
 870
 871 =head2 Use with Other Constraint Modules
 872
 873 This module can play nicely with other constraint modules with some
 874 slight tweaking. The C<where> clause in types is expected to be a
 875 C<CODE> reference which checks its first argument and returns a
 876 boolean. Since most constraint modules work in a similar way, it
 877 should be simple to adapt them to work with Moose.
 878
 879 For instance, this is how you could use it with
 880 L<Declare::Constraints::Simple> to declare a completely new type.
 881
 882   type 'HashOfArrayOfObjects',
 883       where {
 884           IsHashRef(
 885               -keys   => HasLength,
 886               -values => IsArrayRef(IsObject)
 887           )->(@_);
 888       };
 889
 890 For more examples see the F<t/examples/example_w_DCS.t> test
 891 file.
 892
 893 Here is an example of using L<Test::Deep> and its non-test
 894 related C<eq_deeply> function.
 895
 896   type 'ArrayOfHashOfBarsAndRandomNumbers',
 897       where {
 898           eq_deeply($_,
 899               array_each(subhashof({
 900                   bar           => isa('Bar'),
 901                   random_number => ignore()
 902               })))
 903         };
 904
 905 For a complete example see the
 906 F<t/examples/example_w_TestDeep.t> test file.
 907
 908 =head2 Error messages
 909
 910 Type constraints can also specify custom error messages, for when they fail to
 911 validate. This is provided as just another coderef, which receives the invalid
 912 value in C<$_>, as in:
 913
 914   subtype 'PositiveInt',
 915        as 'Int',
 916        where { $_ > 0 },
 917        message { "$_ is not a positive integer!" };
 918
 919 If no message is specified, a default message will be used, which indicates
 920 which type constraint was being used and what value failed. If
 921 L<Devel::PartialDump> (version 0.14 or higher) is installed, it will be used to
 922 display the invalid value, otherwise it will just be printed as is.
 923
 924 =head1 FUNCTIONS
 925
 926 =head2 Type Constraint Constructors
 927
 928 The following functions are used to create type constraints.  They
 929 will also register the type constraints your create in a global
 930 registry that is used to look types up by name.
 931
 932 See the L</SYNOPSIS> for an example of how to use these.
 933
 934 =over 4
 935
 936 =item B<< subtype 'Name', as 'Parent', where { } ... >>
 937
 938 This creates a named subtype.
 939
 940 If you provide a parent that Moose does not recognize, it will
 941 automatically create a new class type constraint for this name.
 942
 943 When creating a named type, the C<subtype> function should either be
 944 called with the sugar helpers (C<where>, C<message>, etc), or with a
 945 name and a hashref of parameters:
 946
 947  subtype( 'Foo', { where => ..., message => ... } );
 948
 949 The valid hashref keys are C<as> (the parent), C<where>, C<message>,
 950 and C<optimize_as>.
 951
 952 =item B<< subtype as 'Parent', where { } ... >>
 953
 954 This creates an unnamed subtype and will return the type
 955 constraint meta-object, which will be an instance of
 956 L<Moose::Meta::TypeConstraint>.
 957
 958 When creating an anonymous type, the C<subtype> function should either
 959 be called with the sugar helpers (C<where>, C<message>, etc), or with
 960 just a hashref of parameters:
 961
 962  subtype( { where => ..., message => ... } );
 963
 964 =item B<class_type ($class, ?$options)>
 965
 966 Creates a new subtype of C<Object> with the name C<$class> and the
 967 metaclass L<Moose::Meta::TypeConstraint::Class>.
 968
 969 =item B<role_type ($role, ?$options)>
 970
 971 Creates a C<Role> type constraint with the name C<$role> and the
 972 metaclass L<Moose::Meta::TypeConstraint::Role>.
 973
 974 =item B<maybe_type ($type)>
 975
 976 Creates a type constraint for either C<undef> or something of the
 977 given type.
 978
 979 =item B<duck_type ($name, \@methods)>
 980
 981 This will create a subtype of Object and test to make sure the value
 982 C<can()> do the methods in C<\@methods>.
 983
 984 This is intended as an easy way to accept non-Moose objects that
 985 provide a certain interface. If you're using Moose classes, we
 986 recommend that you use a C<requires>-only Role instead.
 987
 988 =item B<duck_type (\@methods)>
 989
 990 If passed an ARRAY reference as the only parameter instead of the
 991 C<$name>, C<\@methods> pair, this will create an unnamed duck type.
 992 This can be used in an attribute definition like so:
 993
 994   has 'cache' => (
 995       is  => 'ro',
 996       isa => duck_type( [qw( get_set )] ),
 997   );
 998
 999 =item B<enum ($name, \@values)>
1000
1001 This will create a basic subtype for a given set of strings.
1002 The resulting constraint will be a subtype of C<Str> and
1003 will match any of the items in C<\@values>. It is case sensitive.
1004 See the L</SYNOPSIS> for a simple example.
1005
1006 B<NOTE:> This is not a true proper enum type, it is simply
1007 a convenient constraint builder.
1008
1009 =item B<enum (\@values)>
1010
1011 If passed an ARRAY reference as the only parameter instead of the
1012 C<$name>, C<\@values> pair, this will create an unnamed enum. This
1013 can then be used in an attribute definition like so:
1014
1015   has 'sort_order' => (
1016       is  => 'ro',
1017       isa => enum([qw[ ascending descending ]]),
1018   );
1019
1020 =item B<as 'Parent'>
1021
1022 This is just sugar for the type constraint construction syntax.
1023
1024 It takes a single argument, which is the name of a parent type.
1025
1026 =item B<where { ... }>
1027
1028 This is just sugar for the type constraint construction syntax.
1029
1030 It takes a subroutine reference as an argument. When the type
1031 constraint is tested, the reference is run with the value to be tested
1032 in C<$_>. This reference should return true or false to indicate
1033 whether or not the constraint check passed.
1034
1035 =item B<message { ... }>
1036
1037 This is just sugar for the type constraint construction syntax.
1038
1039 It takes a subroutine reference as an argument. When the type
1040 constraint fails, then the code block is run with the value provided
1041 in C<$_>. This reference should return a string, which will be used in
1042 the text of the exception thrown.
1043
1044 =item B<optimize_as { ... }>
1045
1046 This can be used to define a "hand optimized" version of your
1047 type constraint which can be used to avoid traversing a subtype
1048 constraint hierarchy.
1049
1050 B<NOTE:> You should only use this if you know what you are doing.
1051 All the built in types use this, so your subtypes (assuming they
1052 are shallow) will not likely need to use this.
1053
1054 =item B<< type 'Name', where { } ... >>
1055
1056 This creates a base type, which has no parent.
1057
1058 The C<type> function should either be called with the sugar helpers
1059 (C<where>, C<message>, etc), or with a name and a hashref of
1060 parameters:
1061
1062   type( 'Foo', { where => ..., message => ... } );
1063
1064 The valid hashref keys are C<where>, C<message>, and C<optimize_as>.
1065
1066 =back
1067
1068 =head2 Type Constraint Utilities
1069
1070 =over 4
1071
1072 =item B<< match_on_type $value => ( $type => \&action, ... ?\&default ) >>
1073
1074 This is a utility function for doing simple type based dispatching similar to
1075 match/case in OCaml and case/of in Haskell. It is not as featureful as those
1076 languages, nor does not it support any kind of automatic destructuring
1077 bind. Here is a simple Perl pretty printer dispatching over the core Moose
1078 types.
1079
1080   sub ppprint {
1081       my $x = shift;
1082       match_on_type $x => (
1083           HashRef => sub {
1084               my $hash = shift;
1085               '{ '
1086                   . (
1087                   join ", " => map { $_ . ' => ' . ppprint( $hash->{$_} ) }
1088                       sort keys %$hash
1089                   ) . ' }';
1090           },
1091           ArrayRef => sub {
1092               my $array = shift;
1093               '[ ' . ( join ", " => map { ppprint($_) } @$array ) . ' ]';
1094           },
1095           CodeRef   => sub {'sub { ... }'},
1096           RegexpRef => sub { 'qr/' . $_ . '/' },
1097           GlobRef   => sub { '*' . B::svref_2object($_)->NAME },
1098           Object    => sub { $_->can('to_string') ? $_->to_string : $_ },
1099           ScalarRef => sub { '\\' . ppprint( ${$_} ) },
1100           Num       => sub {$_},
1101           Str       => sub { '"' . $_ . '"' },
1102           Undef     => sub {'undef'},
1103           => sub { die "I don't know what $_ is" }
1104       );
1105   }
1106
1107 Or a simple JSON serializer:
1108
1109   sub to_json {
1110       my $x = shift;
1111       match_on_type $x => (
1112           HashRef => sub {
1113               my $hash = shift;
1114               '{ '
1115                   . (
1116                   join ", " =>
1117                       map { '"' . $_ . '" : ' . to_json( $hash->{$_} ) }
1118                       sort keys %$hash
1119                   ) . ' }';
1120           },
1121           ArrayRef => sub {
1122               my $array = shift;
1123               '[ ' . ( join ", " => map { to_json($_) } @$array ) . ' ]';
1124           },
1125           Num   => sub {$_},
1126           Str   => sub { '"' . $_ . '"' },
1127           Undef => sub {'null'},
1128           => sub { die "$_ is not acceptable json type" }
1129       );
1130   }
1131
1132 The matcher is done by mapping a C<$type> to an C<\&action>. The C<$type> can
1133 be either a string type or a L<Moose::Meta::TypeConstraint> object, and
1134 C<\&action> is a subroutine reference. This function will dispatch on the
1135 first match for C<$value>. It is possible to have a catch-all by providing an
1136 additional subroutine reference as the final argument to C<match_on_type>.
1137
1138 =back
1139
1140 =head2 Type Coercion Constructors
1141
1142 You can define coercions for type constraints, which allow you to
1143 automatically transform values to something valid for the type
1144 constraint. If you ask your accessor to coerce, then Moose will run
1145 the type-coercion code first, followed by the type constraint
1146 check. This feature should be used carefully as it is very powerful
1147 and could easily take off a limb if you are not careful.
1148
1149 See the L</SYNOPSIS> for an example of how to use these.
1150
1151 =over 4
1152
1153 =item B<< coerce 'Name', from 'OtherName', via { ... }  >>
1154
1155 This defines a coercion from one type to another. The C<Name> argument
1156 is the type you are coercing I<to>.
1157
1158 To define multiple coercions, supply more sets of from/via pairs:
1159
1160   coerce 'Name',
1161     from 'OtherName', via { ... },
1162     from 'ThirdName', via { ... };
1163
1164 =item B<from 'OtherName'>
1165
1166 This is just sugar for the type coercion construction syntax.
1167
1168 It takes a single type name (or type object), which is the type being
1169 coerced I<from>.
1170
1171 =item B<via { ... }>
1172
1173 This is just sugar for the type coercion construction syntax.
1174
1175 It takes a subroutine reference. This reference will be called with
1176 the value to be coerced in C<$_>. It is expected to return a new value
1177 of the proper type for the coercion.
1178
1179 =back
1180
1181 =head2 Creating and Finding Type Constraints
1182
1183 These are additional functions for creating and finding type
1184 constraints. Most of these functions are not available for
1185 importing. The ones that are importable as specified.
1186
1187 =over 4
1188
1189 =item B<find_type_constraint($type_name)>
1190
1191 This function can be used to locate the L<Moose::Meta::TypeConstraint>
1192 object for a named type.
1193
1194 This function is importable.
1195
1196 =item B<register_type_constraint($type_object)>
1197
1198 This function will register a L<Moose::Meta::TypeConstraint> with the
1199 global type registry.
1200
1201 This function is importable.
1202
1203 =item B<normalize_type_constraint_name($type_constraint_name)>
1204
1205 This method takes a type constraint name and returns the normalized
1206 form. This removes any whitespace in the string.
1207
1208 =item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)>
1209
1210 This can take a union type specification like C<'Int|ArrayRef[Int]'>,
1211 or a list of names. It returns a new
1212 L<Moose::Meta::TypeConstraint::Union> object.
1213
1214 =item B<create_parameterized_type_constraint($type_name)>
1215
1216 Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>,
1217 this will create a new L<Moose::Meta::TypeConstraint::Parameterized>
1218 object. The C<BaseType> must exist already exist as a parameterizable
1219 type.
1220
1221 =item B<create_class_type_constraint($class, $options)>
1222
1223 Given a class name this function will create a new
1224 L<Moose::Meta::TypeConstraint::Class> object for that class name.
1225
1226 The C<$options> is a hash reference that will be passed to the
1227 L<Moose::Meta::TypeConstraint::Class> constructor (as a hash).
1228
1229 =item B<create_role_type_constraint($role, $options)>
1230
1231 Given a role name this function will create a new
1232 L<Moose::Meta::TypeConstraint::Role> object for that role name.
1233
1234 The C<$options> is a hash reference that will be passed to the
1235 L<Moose::Meta::TypeConstraint::Role> constructor (as a hash).
1236
1237 =item B<create_enum_type_constraint($name, $values)>
1238
1239 Given a enum name this function will create a new
1240 L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
1241
1242 =item B<create_duck_type_constraint($name, $methods)>
1243
1244 Given a duck type name this function will create a new
1245 L<Moose::Meta::TypeConstraint::DuckType> object for that enum name.
1246
1247 =item B<find_or_parse_type_constraint($type_name)>
1248
1249 Given a type name, this first attempts to find a matching constraint
1250 in the global registry.
1251
1252 If the type name is a union or parameterized type, it will create a
1253 new object of the appropriate, but if given a "regular" type that does
1254 not yet exist, it simply returns false.
1255
1256 When given a union or parameterized type, the member or base type must
1257 already exist.
1258
1259 If it creates a new union or parameterized type, it will add it to the
1260 global registry.
1261
1262 =item B<find_or_create_isa_type_constraint($type_name)>
1263
1264 =item B<find_or_create_does_type_constraint($type_name)>
1265
1266 These functions will first call C<find_or_parse_type_constraint>. If
1267 that function does not return a type, a new type object will
1268 be created.
1269
1270 The C<isa> variant will use C<create_class_type_constraint> and the
1271 C<does> variant will use C<create_role_type_constraint>.
1272
1273 =item B<get_type_constraint_registry>
1274
1275 Returns the L<Moose::Meta::TypeConstraint::Registry> object which
1276 keeps track of all type constraints.
1277
1278 =item B<list_all_type_constraints>
1279
1280 This will return a list of type constraint names in the global
1281 registry. You can then fetch the actual type object using
1282 C<find_type_constraint($type_name)>.
1283
1284 =item B<list_all_builtin_type_constraints>
1285
1286 This will return a list of builtin type constraints, meaning those
1287 which are defined in this module. See the L<Default Type Constraints>
1288 section for a complete list.
1289
1290 =item B<export_type_constraints_as_functions>
1291
1292 This will export all the current type constraints as functions into
1293 the caller's namespace (C<Int()>, C<Str()>, etc). Right now, this is
1294 mostly used for testing, but it might prove useful to others.
1295
1296 =item B<get_all_parameterizable_types>
1297
1298 This returns all the parameterizable types that have been registered,
1299 as a list of type objects.
1300
1301 =item B<add_parameterizable_type($type)>
1302
1303 Adds C<$type> to the list of parameterizable types
1304
1305 =back
1306
1307 =head1 BUGS
1308
1309 See L<Moose/BUGS> for details on reporting bugs.
1310
1311 =cut