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