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