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