lib/Moose/Util/TypeConstraints.pm

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