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