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