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 'DateTimeish', { 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 Additionally, you can create a class_type which is a shorthand for another class.
 970
 971   # Create a type called 'Box' which tests for objects which ->isa('ObjectLibrary::Box');
 972   class_type 'Box', { class => 'ObjectLibrary::Box' };
 973
 974 But it's only really necessary to do this if you're working with L<MooseX::Types>.
 975
 976 =item B<role_type ($role, ?$options)>
 977
 978 Creates a C<Role> type constraint with the name C<$role> and the
 979 metaclass L<Moose::Meta::TypeConstraint::Role>.
 980
 981   # Create a type called 'Walks' which tests for objects which ->does('Walks')
 982   role_type 'Walks';
 983
 984 Additionally, you can create a role_type which is a shorthand for another role.
 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 But it's only really necessary to do this if you're working with L<MooseX::Types>.
 990
 991 =item B<maybe_type ($type)>
 992
 993 Creates a type constraint for either C<undef> or something of the
 994 given type.
 995
 996 =item B<duck_type ($name, \@methods)>
 997
 998 This will create a subtype of Object and test to make sure the value
 999 C<can()> do the methods in C<\@methods>.
1000
1001 This is intended as an easy way to accept non-Moose objects that
1002 provide a certain interface. If you're using Moose classes, we
1003 recommend that you use a C<requires>-only Role instead.
1004
1005 =item B<duck_type (\@methods)>
1006
1007 If passed an ARRAY reference as the only parameter instead of the
1008 C<$name>, C<\@methods> pair, this will create an unnamed duck type.
1009 This can be used in an attribute definition like so:
1010
1011   has 'cache' => (
1012       is  => 'ro',
1013       isa => duck_type( [qw( get_set )] ),
1014   );
1015
1016 =item B<enum ($name, \@values)>
1017
1018 This will create a basic subtype for a given set of strings.
1019 The resulting constraint will be a subtype of C<Str> and
1020 will match any of the items in C<\@values>. It is case sensitive.
1021 See the L</SYNOPSIS> for a simple example.
1022
1023 B<NOTE:> This is not a true proper enum type, it is simply
1024 a convenient constraint builder.
1025
1026 =item B<enum (\@values)>
1027
1028 If passed an ARRAY reference as the only parameter instead of the
1029 C<$name>, C<\@values> pair, this will create an unnamed enum. This
1030 can then be used in an attribute definition like so:
1031
1032   has 'sort_order' => (
1033       is  => 'ro',
1034       isa => enum([qw[ ascending descending ]]),
1035   );
1036
1037 =item B<union ($name, \@constraints)>
1038
1039 This will create a basic subtype where any of the provided constraints
1040 may match in order to satisfy this constraint.
1041
1042 =item B<union (\@constraints)>
1043
1044 If passed an ARRAY reference as the only parameter instead of the
1045 C<$name>, C<\@constraints> pair, this will create an unnamed union.
1046 This can then be used in an attribute definition like so:
1047
1048   has 'items' => (
1049       is => 'ro',
1050       isa => union([qw[ Str ArrayRef ]]),
1051   );
1052
1053 This is similar to the existing string union:
1054
1055   isa => 'Str|ArrayRef'
1056
1057 except that it supports anonymous elements as child constraints:
1058
1059   has 'color' => (
1060     isa => 'ro',
1061     isa => union([ 'Int',  enum([qw[ red green blue ]]) ]),
1062   );
1063
1064 =item B<as 'Parent'>
1065
1066 This is just sugar for the type constraint construction syntax.
1067
1068 It takes a single argument, which is the name of a parent type.
1069
1070 =item B<where { ... }>
1071
1072 This is just sugar for the type constraint construction syntax.
1073
1074 It takes a subroutine reference as an argument. When the type
1075 constraint is tested, the reference is run with the value to be tested
1076 in C<$_>. This reference should return true or false to indicate
1077 whether or not the constraint check passed.
1078
1079 =item B<message { ... }>
1080
1081 This is just sugar for the type constraint construction syntax.
1082
1083 It takes a subroutine reference as an argument. When the type
1084 constraint fails, then the code block is run with the value provided
1085 in C<$_>. This reference should return a string, which will be used in
1086 the text of the exception thrown.
1087
1088 =item B<inline_as { ... }>
1089
1090 This can be used to define a "hand optimized" inlinable version of your type
1091 constraint.
1092
1093 You provide a subroutine which will be called I<as a method> on a
1094 L<Moose::Meta::TypeConstraint> object. It will receive a single parameter, the
1095 name of the variable to check, typically something like C<"$_"> or C<"$_[0]">.
1096
1097 The subroutine should return a code string suitable for inlining. You can
1098 assume that the check will be wrapped in parentheses when it is inlined.
1099
1100 The inlined code should include any checks that your type's parent types
1101 do. For example, the C<Value> type's inlining sub looks like this:
1102
1103     sub {
1104         'defined(' . $_[1] . ')'
1105         . ' && !ref(' . $_[1] . ')'
1106     }
1107
1108 Note that it checks if the variable is defined, since it is a subtype of
1109 the C<Defined> type.  However, to avoid repeating code, this can be optimized as:
1110
1111     sub {
1112         $_[0]->parent()->_inline_check($_[1])
1113         . ' && !ref(' . $_[1] . ')'
1114     }
1115
1116 =item B<optimize_as { ... }>
1117
1118 B<This feature is deprecated, use C<inline_as> instead.>
1119
1120 This can be used to define a "hand optimized" version of your
1121 type constraint which can be used to avoid traversing a subtype
1122 constraint hierarchy.
1123
1124 B<NOTE:> You should only use this if you know what you are doing.
1125 All the built in types use this, so your subtypes (assuming they
1126 are shallow) will not likely need to use this.
1127
1128 =item B<< type 'Name', where { } ... >>
1129
1130 This creates a base type, which has no parent.
1131
1132 The C<type> function should either be called with the sugar helpers
1133 (C<where>, C<message>, etc), or with a name and a hashref of
1134 parameters:
1135
1136   type( 'Foo', { where => ..., message => ... } );
1137
1138 The valid hashref keys are C<where>, C<message>, and C<inlined_as>.
1139
1140 =back
1141
1142 =head2 Type Constraint Utilities
1143
1144 =over 4
1145
1146 =item B<< match_on_type $value => ( $type => \&action, ... ?\&default ) >>
1147
1148 This is a utility function for doing simple type based dispatching similar to
1149 match/case in OCaml and case/of in Haskell. It is not as featureful as those
1150 languages, nor does not it support any kind of automatic destructuring
1151 bind. Here is a simple Perl pretty printer dispatching over the core Moose
1152 types.
1153
1154   sub ppprint {
1155       my $x = shift;
1156       match_on_type $x => (
1157           HashRef => sub {
1158               my $hash = shift;
1159               '{ '
1160                   . (
1161                   join ", " => map { $_ . ' => ' . ppprint( $hash->{$_} ) }
1162                       sort keys %$hash
1163                   ) . ' }';
1164           },
1165           ArrayRef => sub {
1166               my $array = shift;
1167               '[ ' . ( join ", " => map { ppprint($_) } @$array ) . ' ]';
1168           },
1169           CodeRef   => sub {'sub { ... }'},
1170           RegexpRef => sub { 'qr/' . $_ . '/' },
1171           GlobRef   => sub { '*' . B::svref_2object($_)->NAME },
1172           Object    => sub { $_->can('to_string') ? $_->to_string : $_ },
1173           ScalarRef => sub { '\\' . ppprint( ${$_} ) },
1174           Num       => sub {$_},
1175           Str       => sub { '"' . $_ . '"' },
1176           Undef     => sub {'undef'},
1177           => sub { die "I don't know what $_ is" }
1178       );
1179   }
1180
1181 Or a simple JSON serializer:
1182
1183   sub to_json {
1184       my $x = shift;
1185       match_on_type $x => (
1186           HashRef => sub {
1187               my $hash = shift;
1188               '{ '
1189                   . (
1190                   join ", " =>
1191                       map { '"' . $_ . '" : ' . to_json( $hash->{$_} ) }
1192                       sort keys %$hash
1193                   ) . ' }';
1194           },
1195           ArrayRef => sub {
1196               my $array = shift;
1197               '[ ' . ( join ", " => map { to_json($_) } @$array ) . ' ]';
1198           },
1199           Num   => sub {$_},
1200           Str   => sub { '"' . $_ . '"' },
1201           Undef => sub {'null'},
1202           => sub { die "$_ is not acceptable json type" }
1203       );
1204   }
1205
1206 The matcher is done by mapping a C<$type> to an C<\&action>. The C<$type> can
1207 be either a string type or a L<Moose::Meta::TypeConstraint> object, and
1208 C<\&action> is a subroutine reference. This function will dispatch on the
1209 first match for C<$value>. It is possible to have a catch-all by providing an
1210 additional subroutine reference as the final argument to C<match_on_type>.
1211
1212 =back
1213
1214 =head2 Type Coercion Constructors
1215
1216 You can define coercions for type constraints, which allow you to
1217 automatically transform values to something valid for the type
1218 constraint. If you ask your accessor to coerce, then Moose will run
1219 the type-coercion code first, followed by the type constraint
1220 check. This feature should be used carefully as it is very powerful
1221 and could easily take off a limb if you are not careful.
1222
1223 See the L</SYNOPSIS> for an example of how to use these.
1224
1225 =over 4
1226
1227 =item B<< coerce 'Name', from 'OtherName', via { ... }  >>
1228
1229 This defines a coercion from one type to another. The C<Name> argument
1230 is the type you are coercing I<to>.
1231
1232 To define multiple coercions, supply more sets of from/via pairs:
1233
1234   coerce 'Name',
1235     from 'OtherName', via { ... },
1236     from 'ThirdName', via { ... };
1237
1238 =item B<from 'OtherName'>
1239
1240 This is just sugar for the type coercion construction syntax.
1241
1242 It takes a single type name (or type object), which is the type being
1243 coerced I<from>.
1244
1245 =item B<via { ... }>
1246
1247 This is just sugar for the type coercion construction syntax.
1248
1249 It takes a subroutine reference. This reference will be called with
1250 the value to be coerced in C<$_>. It is expected to return a new value
1251 of the proper type for the coercion.
1252
1253 =back
1254
1255 =head2 Creating and Finding Type Constraints
1256
1257 These are additional functions for creating and finding type
1258 constraints. Most of these functions are not available for
1259 importing. The ones that are importable as specified.
1260
1261 =over 4
1262
1263 =item B<find_type_constraint($type_name)>
1264
1265 This function can be used to locate the L<Moose::Meta::TypeConstraint>
1266 object for a named type.
1267
1268 This function is importable.
1269
1270 =item B<register_type_constraint($type_object)>
1271
1272 This function will register a L<Moose::Meta::TypeConstraint> with the
1273 global type registry.
1274
1275 This function is importable.
1276
1277 =item B<normalize_type_constraint_name($type_constraint_name)>
1278
1279 This method takes a type constraint name and returns the normalized
1280 form. This removes any whitespace in the string.
1281
1282 =item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)>
1283
1284 =item B<create_named_type_constraint_union($name, $pipe_separated_types | @type_constraint_names)>
1285
1286 This can take a union type specification like C<'Int|ArrayRef[Int]'>,
1287 or a list of names. It returns a new
1288 L<Moose::Meta::TypeConstraint::Union> object.
1289
1290 =item B<create_parameterized_type_constraint($type_name)>
1291
1292 Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>,
1293 this will create a new L<Moose::Meta::TypeConstraint::Parameterized>
1294 object. The C<BaseType> must exist already exist as a parameterizable
1295 type.
1296
1297 =item B<create_class_type_constraint($class, $options)>
1298
1299 Given a class name this function will create a new
1300 L<Moose::Meta::TypeConstraint::Class> object for that class name.
1301
1302 The C<$options> is a hash reference that will be passed to the
1303 L<Moose::Meta::TypeConstraint::Class> constructor (as a hash).
1304
1305 =item B<create_role_type_constraint($role, $options)>
1306
1307 Given a role name this function will create a new
1308 L<Moose::Meta::TypeConstraint::Role> object for that role name.
1309
1310 The C<$options> is a hash reference that will be passed to the
1311 L<Moose::Meta::TypeConstraint::Role> constructor (as a hash).
1312
1313 =item B<create_enum_type_constraint($name, $values)>
1314
1315 Given a enum name this function will create a new
1316 L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
1317
1318 =item B<create_duck_type_constraint($name, $methods)>
1319
1320 Given a duck type name this function will create a new
1321 L<Moose::Meta::TypeConstraint::DuckType> object for that enum name.
1322
1323 =item B<find_or_parse_type_constraint($type_name)>
1324
1325 Given a type name, this first attempts to find a matching constraint
1326 in the global registry.
1327
1328 If the type name is a union or parameterized type, it will create a
1329 new object of the appropriate, but if given a "regular" type that does
1330 not yet exist, it simply returns false.
1331
1332 When given a union or parameterized type, the member or base type must
1333 already exist.
1334
1335 If it creates a new union or parameterized type, it will add it to the
1336 global registry.
1337
1338 =item B<find_or_create_isa_type_constraint($type_name)>
1339
1340 =item B<find_or_create_does_type_constraint($type_name)>
1341
1342 These functions will first call C<find_or_parse_type_constraint>. If
1343 that function does not return a type, a new type object will
1344 be created.
1345
1346 The C<isa> variant will use C<create_class_type_constraint> and the
1347 C<does> variant will use C<create_role_type_constraint>.
1348
1349 =item B<get_type_constraint_registry>
1350
1351 Returns the L<Moose::Meta::TypeConstraint::Registry> object which
1352 keeps track of all type constraints.
1353
1354 =item B<list_all_type_constraints>
1355
1356 This will return a list of type constraint names in the global
1357 registry. You can then fetch the actual type object using
1358 C<find_type_constraint($type_name)>.
1359
1360 =item B<list_all_builtin_type_constraints>
1361
1362 This will return a list of builtin type constraints, meaning those
1363 which are defined in this module. See the L<Default Type Constraints>
1364 section for a complete list.
1365
1366 =item B<export_type_constraints_as_functions>
1367
1368 This will export all the current type constraints as functions into
1369 the caller's namespace (C<Int()>, C<Str()>, etc). Right now, this is
1370 mostly used for testing, but it might prove useful to others.
1371
1372 =item B<get_all_parameterizable_types>
1373
1374 This returns all the parameterizable types that have been registered,
1375 as a list of type objects.
1376
1377 =item B<add_parameterizable_type($type)>
1378
1379 Adds C<$type> to the list of parameterizable types
1380
1381 =back
1382
1383 =head1 BUGS
1384
1385 See L<Moose/BUGS> for details on reporting bugs.
1386
1387 =cut