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