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