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