lib/Moose/Util/TypeConstraints.pm

   1
   2 package Moose::Util::TypeConstraints;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp ();
   8 use List::MoreUtils qw( all any );
   9 use Scalar::Util qw( blessed reftype );
  10 use Moose::Exporter;
  11
  12 our $VERSION   = '0.72';
  13 $VERSION = eval $VERSION;
  14 our $AUTHORITY = 'cpan:STEVAN';
  15
  16 ## --------------------------------------------------------
  17 # Prototyped subs must be predeclared because we have a
  18 # circular dependency with Moose::Meta::Attribute et. al.
  19 # so in case of us being use'd first the predeclaration
  20 # ensures the prototypes are in scope when consumers are
  21 # compiled.
  22
  23 # dah sugah!
  24 sub where       (&);
  25 sub via         (&);
  26 sub message     (&);
  27 sub optimize_as (&);
  28
  29 ## --------------------------------------------------------
  30
  31 use Moose::Meta::TypeConstraint;
  32 use Moose::Meta::TypeConstraint::Union;
  33 use Moose::Meta::TypeConstraint::Parameterized;
  34 use Moose::Meta::TypeConstraint::Parameterizable;
  35 use Moose::Meta::TypeConstraint::Class;
  36 use Moose::Meta::TypeConstraint::Role;
  37 use Moose::Meta::TypeConstraint::Enum;
  38 use Moose::Meta::TypeCoercion;
  39 use Moose::Meta::TypeCoercion::Union;
  40 use Moose::Meta::TypeConstraint::Registry;
  41 use Moose::Util::TypeConstraints::OptimizedConstraints;
  42
  43 Moose::Exporter->setup_import_methods(
  44     as_is => [
  45         qw(
  46             type subtype class_type role_type maybe_type
  47             as where message optimize_as
  48             coerce from via
  49             enum
  50             find_type_constraint
  51             register_type_constraint )
  52     ],
  53     _export_to_main => 1,
  54 );
  55
  56 ## --------------------------------------------------------
  57 ## type registry and some useful functions for it
  58 ## --------------------------------------------------------
  59
  60 my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new;
  61
  62 sub get_type_constraint_registry         { $REGISTRY }
  63 sub list_all_type_constraints            { keys %{$REGISTRY->type_constraints} }
  64 sub export_type_constraints_as_functions {
  65     my $pkg = caller();
  66     no strict 'refs';
  67     foreach my $constraint (keys %{$REGISTRY->type_constraints}) {
  68         my $tc = $REGISTRY->get_type_constraint($constraint)->_compiled_type_constraint;
  69         *{"${pkg}::${constraint}"} = sub { $tc->($_[0]) ? 1 : undef }; # the undef is for compat
  70     }
  71 }
  72
  73 sub create_type_constraint_union {
  74     my @type_constraint_names;
  75
  76     if (scalar @_ == 1 && _detect_type_constraint_union($_[0])) {
  77         @type_constraint_names = _parse_type_constraint_union($_[0]);
  78     }
  79     else {
  80         @type_constraint_names = @_;
  81     }
  82
  83     (scalar @type_constraint_names >= 2)
  84         || __PACKAGE__->_throw_error("You must pass in at least 2 type names to make a union");
  85
  86     my @type_constraints = map {
  87         find_or_parse_type_constraint($_) ||
  88          __PACKAGE__->_throw_error("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
  96 sub create_parameterized_type_constraint {
  97     my $type_constraint_name = shift;
  98     my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name);
  99
 100     (defined $base_type && defined $type_parameter)
 101         || __PACKAGE__->_throw_error("Could not parse type name ($type_constraint_name) correctly");
 102
 103     if ($REGISTRY->has_type_constraint($base_type)) {
 104         my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
 105         return _create_parameterized_type_constraint(
 106             $base_type_tc,
 107             $type_parameter
 108         );
 109     } else {
 110         __PACKAGE__->_throw_error("Could not locate the base type ($base_type)");
 111     }
 112 }
 113
 114 sub _create_parameterized_type_constraint {
 115     my ( $base_type_tc, $type_parameter ) = @_;
 116     if ( $base_type_tc->can('parameterize') ) {
 117         return $base_type_tc->parameterize($type_parameter);
 118     } else {
 119         return Moose::Meta::TypeConstraint::Parameterized->new(
 120             name => $base_type_tc->name . '[' . $type_parameter . ']',
 121             parent => $base_type_tc,
 122             type_parameter => find_or_create_isa_type_constraint($type_parameter),
 123         );
 124     }
 125 }
 126
 127 #should we also support optimized checks?
 128 sub create_class_type_constraint {
 129     my ( $class, $options ) = @_;
 130
 131     # too early for this check
 132     #find_type_constraint("ClassName")->check($class)
 133     #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
 134
 135     my %options = (
 136         class => $class,
 137         name  => $class,
 138         %{ $options || {} },
 139     );
 140
 141     $options{name} ||= "__ANON__";
 142
 143     Moose::Meta::TypeConstraint::Class->new( %options );
 144 }
 145
 146 sub create_role_type_constraint {
 147     my ( $role, $options ) = @_;
 148
 149     # too early for this check
 150     #find_type_constraint("ClassName")->check($class)
 151     #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
 152
 153     my %options = (
 154         role => $role,
 155         name => $role,
 156         %{ $options || {} },
 157     );
 158
 159     $options{name} ||= "__ANON__";
 160
 161     Moose::Meta::TypeConstraint::Role->new( %options );
 162 }
 163
 164
 165 sub find_or_create_type_constraint {
 166     my ( $type_constraint_name, $options_for_anon_type ) = @_;
 167
 168     if ( my $constraint = find_or_parse_type_constraint($type_constraint_name) ) {
 169         return $constraint;
 170     }
 171     elsif ( defined $options_for_anon_type ) {
 172         # NOTE:
 173         # if there is no $options_for_anon_type
 174         # specified, then we assume they don't
 175         # want to create one, and return nothing.
 176
 177         # otherwise assume that we should create
 178         # an ANON type with the $options_for_anon_type
 179         # options which can be passed in. It should
 180         # be noted that these don't get registered
 181         # so we need to return it.
 182         # - SL
 183         return Moose::Meta::TypeConstraint->new(
 184             name => '__ANON__',
 185             %{$options_for_anon_type}
 186         );
 187     }
 188
 189     return;
 190 }
 191
 192 sub find_or_create_isa_type_constraint {
 193     my $type_constraint_name = shift;
 194     find_or_parse_type_constraint($type_constraint_name) || create_class_type_constraint($type_constraint_name)
 195 }
 196
 197 sub find_or_create_does_type_constraint {
 198     my $type_constraint_name = shift;
 199     find_or_parse_type_constraint($type_constraint_name) || create_role_type_constraint($type_constraint_name)
 200 }
 201
 202 sub find_or_parse_type_constraint {
 203     my $type_constraint_name = normalize_type_constraint_name(shift);
 204     my $constraint;
 205
 206     if ($constraint = find_type_constraint($type_constraint_name)) {
 207         return $constraint;
 208     } elsif (_detect_type_constraint_union($type_constraint_name)) {
 209         $constraint = create_type_constraint_union($type_constraint_name);
 210     } elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
 211         $constraint = create_parameterized_type_constraint($type_constraint_name);
 212     } else {
 213         return;
 214     }
 215
 216     $REGISTRY->add_type_constraint($constraint);
 217     return $constraint;
 218 }
 219
 220 sub normalize_type_constraint_name {
 221     my $type_constraint_name = shift;
 222     $type_constraint_name =~ s/\s//g;
 223     return $type_constraint_name;
 224 }
 225
 226 sub _confess {
 227     my $error = shift;
 228
 229     local $Carp::CarpLevel = $Carp::CarpLevel + 1;
 230     Carp::confess($error);
 231 }
 232
 233 ## --------------------------------------------------------
 234 ## exported functions ...
 235 ## --------------------------------------------------------
 236
 237 sub find_type_constraint {
 238     my $type = shift;
 239
 240     if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) {
 241         return $type;
 242     }
 243     else {
 244         return unless $REGISTRY->has_type_constraint($type);
 245         return $REGISTRY->get_type_constraint($type);
 246     }
 247 }
 248
 249 sub register_type_constraint {
 250     my $constraint = shift;
 251     __PACKAGE__->_throw_error("can't register an unnamed type constraint") unless defined $constraint->name;
 252     $REGISTRY->add_type_constraint($constraint);
 253     return $constraint;
 254 }
 255
 256 # type constructors
 257
 258 sub type {
 259     # back-compat version, called without sugar
 260     if ( ! any { ( reftype($_) || '' ) eq 'HASH' } @_ ) {
 261         return _create_type_constraint( $_[0], undef, $_[1] );
 262     }
 263
 264     my $name = shift;
 265
 266     my %p = map { %{$_} } @_;
 267
 268     return _create_type_constraint( $name, undef, $p{where}, $p{message}, $p{optimize_as} );
 269 }
 270
 271 sub subtype {
 272     # crazy back-compat code for being called without sugar ...
 273     #
 274     # subtype 'Parent', sub { where };
 275     if ( scalar @_ == 2 && ( reftype( $_[1] ) || '' ) eq 'CODE' ) {
 276         return _create_type_constraint( undef, @_ );
 277     }
 278
 279     # subtype 'Parent', sub { where }, sub { message };
 280     # subtype 'Parent', sub { where }, sub { message }, sub { optimized };
 281     if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' }
 282          @_[ 1 .. $#_ ] ) {
 283         return _create_type_constraint( undef, @_ );
 284     }
 285
 286     # subtype 'Name', 'Parent', ...
 287     if ( scalar @_ >= 2 && all { !ref } @_[ 0, 1 ] ) {
 288         return _create_type_constraint(@_);
 289     }
 290
 291     # The blessed check is mostly to accommodate MooseX::Types, which
 292     # uses an object which overloads stringification as a type name.
 293     my $name = ref $_[0] && ! blessed $_[0] ? undef : shift;
 294
 295     my %p = map { %{$_} } @_;
 296
 297     # subtype Str => where { ... };
 298     if ( ! exists $p{as} ) {
 299         $p{as} = $name;
 300         $name = undef;
 301     }
 302
 303     return _create_type_constraint( $name, $p{as}, $p{where}, $p{message}, $p{optimize_as} );
 304 }
 305
 306 sub class_type {
 307     register_type_constraint(
 308         create_class_type_constraint(
 309             $_[0],
 310             ( defined($_[1]) ? $_[1] : () ),
 311         )
 312     );
 313 }
 314
 315 sub role_type ($;$) {
 316     register_type_constraint(
 317         create_role_type_constraint(
 318             $_[0],
 319             ( defined($_[1]) ? $_[1] : () ),
 320         )
 321     );
 322 }
 323
 324 sub maybe_type {
 325     my ($type_parameter) = @_;
 326
 327     register_type_constraint(
 328         $REGISTRY->get_type_constraint('Maybe')->parameterize($type_parameter)
 329     );
 330 }
 331
 332 sub coerce {
 333     my ($type_name, @coercion_map) = @_;
 334     _install_type_coercions($type_name, \@coercion_map);
 335 }
 336
 337 # The trick of returning @_ lets us avoid having to specify a
 338 # prototype. Perl will parse this:
 339 #
 340 # subtype 'Foo'
 341 #     => as 'Str'
 342 #     => where { ... }
 343 #
 344 # as this:
 345 #
 346 # subtype( 'Foo', as( 'Str', where { ... } ) );
 347 #
 348 # If as() returns all it's extra arguments, this just works, and
 349 # preserves backwards compatibility.
 350 sub as              { { as          => shift }, @_ }
 351 sub where (&)       { { where       => $_[0] } }
 352 sub message (&)     { { message     => $_[0] } }
 353 sub optimize_as (&) { { optimize_as => $_[0] } }
 354
 355 sub from    {@_}
 356 sub via (&) { $_[0] }
 357
 358 sub enum {
 359     my ($type_name, @values) = @_;
 360     # NOTE:
 361     # if only an array-ref is passed then
 362     # you get an anon-enum
 363     # - SL
 364     if (ref $type_name eq 'ARRAY' && !@values) {
 365         @values    = @$type_name;
 366         $type_name = undef;
 367     }
 368     (scalar @values >= 2)
 369         || __PACKAGE__->_throw_error("You must have at least two values to enumerate through");
 370     my %valid = map { $_ => 1 } @values;
 371
 372     register_type_constraint(
 373         create_enum_type_constraint(
 374             $type_name,
 375             \@values,
 376         )
 377     );
 378 }
 379
 380 sub create_enum_type_constraint {
 381     my ( $type_name, $values ) = @_;
 382
 383     Moose::Meta::TypeConstraint::Enum->new(
 384         name   => $type_name || '__ANON__',
 385         values => $values,
 386     );
 387 }
 388
 389 ## --------------------------------------------------------
 390 ## desugaring functions ...
 391 ## --------------------------------------------------------
 392
 393 sub _create_type_constraint ($$$;$$) {
 394     my $name      = shift;
 395     my $parent    = shift;
 396     my $check     = shift;
 397     my $message   = shift;
 398     my $optimized = shift;
 399
 400     my $pkg_defined_in = scalar( caller(1) );
 401
 402     if ( defined $name ) {
 403         my $type = $REGISTRY->get_type_constraint($name);
 404
 405         ( $type->_package_defined_in eq $pkg_defined_in )
 406             || _confess(
 407                   "The type constraint '$name' has already been created in "
 408                 . $type->_package_defined_in
 409                 . " and cannot be created again in "
 410                 . $pkg_defined_in )
 411             if defined $type;
 412
 413         $name =~ /^[\w:\.]+$/
 414             or die qq{$name contains invalid characters for a type name.}
 415             . qq{ Names can contain alphanumeric character, ":", and "."\n};
 416     }
 417
 418     my %opts = (
 419         name               => $name,
 420         package_defined_in => $pkg_defined_in,
 421
 422         ( $check     ? ( constraint => $check )     : () ),
 423         ( $message   ? ( message    => $message )   : () ),
 424         ( $optimized ? ( optimized  => $optimized ) : () ),
 425     );
 426
 427     my $constraint;
 428     if ( defined $parent
 429         and $parent
 430         = blessed $parent ? $parent : find_or_create_isa_type_constraint($parent) )
 431     {
 432         $constraint = $parent->create_child_type(%opts);
 433     }
 434     else {
 435         $constraint = Moose::Meta::TypeConstraint->new(%opts);
 436     }
 437
 438     $REGISTRY->add_type_constraint($constraint)
 439         if defined $name;
 440
 441     return $constraint;
 442 }
 443
 444 sub _install_type_coercions ($$) {
 445     my ($type_name, $coercion_map) = @_;
 446     my $type = find_type_constraint($type_name);
 447     (defined $type)
 448         || __PACKAGE__->_throw_error("Cannot find type '$type_name', perhaps you forgot to load it.");
 449     if ($type->has_coercion) {
 450         $type->coercion->add_type_coercions(@$coercion_map);
 451     }
 452     else {
 453         my $type_coercion = Moose::Meta::TypeCoercion->new(
 454             type_coercion_map => $coercion_map,
 455             type_constraint   => $type
 456         );
 457         $type->coercion($type_coercion);
 458     }
 459 }
 460
 461 ## --------------------------------------------------------
 462 ## type notation parsing ...
 463 ## --------------------------------------------------------
 464
 465 {
 466     # All I have to say is mugwump++ cause I know
 467     # do not even have enough regexp-fu to be able
 468     # to have written this (I can only barely
 469     # understand it as it is)
 470     # - SL
 471
 472     use re "eval";
 473
 474     my $valid_chars = qr{[\w:\.]};
 475     my $type_atom   = qr{ $valid_chars+ };
 476
 477     my $any;
 478
 479     my $type                = qr{  $valid_chars+  (?: \[ \s* (??{$any})   \s* \] )? }x;
 480     my $type_capture_parts  = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x;
 481     my $type_with_parameter = qr{  $valid_chars+      \[ \s* (??{$any})   \s* \]    }x;
 482
 483     my $op_union = qr{ \s* \| \s* }x;
 484     my $union    = qr{ $type (?: $op_union $type )+ }x;
 485
 486     $any = qr{ $type | $union }x;
 487
 488     sub _parse_parameterized_type_constraint {
 489         { no warnings 'void'; $any; } # force capture of interpolated lexical
 490         $_[0] =~ m{ $type_capture_parts }x;
 491         return ($1, $2);
 492     }
 493
 494     sub _detect_parameterized_type_constraint {
 495         { no warnings 'void'; $any; } # force capture of interpolated lexical
 496         $_[0] =~ m{ ^ $type_with_parameter $ }x;
 497     }
 498
 499     sub _parse_type_constraint_union {
 500         { no warnings 'void'; $any; } # force capture of interpolated lexical
 501         my $given = shift;
 502         my @rv;
 503         while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
 504             push @rv => $1;
 505         }
 506         (pos($given) eq length($given))
 507             || __PACKAGE__->_throw_error("'$given' didn't parse (parse-pos="
 508                      . pos($given)
 509                      . " and str-length="
 510                      . length($given)
 511                      . ")");
 512         @rv;
 513     }
 514
 515     sub _detect_type_constraint_union {
 516         { no warnings 'void'; $any; } # force capture of interpolated lexical
 517         $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
 518     }
 519 }
 520
 521 ## --------------------------------------------------------
 522 # define some basic built-in types
 523 ## --------------------------------------------------------
 524
 525 # By making these classes immutable before creating all the types we
 526 # below, we avoid repeatedly calling the slow MOP-based accessors.
 527 $_->make_immutable(
 528     inline_constructor => 1,
 529     constructor_name   => "_new",
 530
 531     # these are Class::MOP accessors, so they need inlining
 532     inline_accessors => 1
 533     ) for grep { $_->is_mutable }
 534     map { $_->meta }
 535     qw(
 536     Moose::Meta::TypeConstraint
 537     Moose::Meta::TypeConstraint::Union
 538     Moose::Meta::TypeConstraint::Parameterized
 539     Moose::Meta::TypeConstraint::Parameterizable
 540     Moose::Meta::TypeConstraint::Class
 541     Moose::Meta::TypeConstraint::Role
 542     Moose::Meta::TypeConstraint::Enum
 543     Moose::Meta::TypeConstraint::Registry
 544 );
 545
 546 type 'Any'  => where { 1 }; # meta-type including all
 547 type 'Item' => where { 1 }; # base-type
 548
 549 subtype 'Undef'   => as 'Item' => where { !defined($_) };
 550 subtype 'Defined' => as 'Item' => where {  defined($_) };
 551
 552 subtype 'Bool'
 553     => as 'Item'
 554     => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
 555
 556 subtype 'Value'
 557     => as 'Defined'
 558     => where { !ref($_) }
 559     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Value;
 560
 561 subtype 'Ref'
 562     => as 'Defined'
 563     => where {  ref($_) }
 564     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref;
 565
 566 subtype 'Str'
 567     => as 'Value'
 568     => where { 1 }
 569     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str;
 570
 571 subtype 'Num'
 572     => as 'Value'
 573     => where { Scalar::Util::looks_like_number($_) }
 574     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Num;
 575
 576 subtype 'Int'
 577     => as 'Num'
 578     => where { "$_" =~ /^-?[0-9]+$/ }
 579     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
 580
 581 subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef;
 582 subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
 583 subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
 584 subtype 'GlobRef'   => as 'Ref' => where { ref($_) eq 'GLOB'   } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
 585
 586 # NOTE:
 587 # scalar filehandles are GLOB refs,
 588 # but a GLOB ref is not always a filehandle
 589 subtype 'FileHandle'
 590     => as 'GlobRef'
 591     => where { Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") ) }
 592     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
 593
 594 # NOTE:
 595 # blessed(qr/.../) returns true,.. how odd
 596 subtype 'Object'
 597     => as 'Ref'
 598     => where { blessed($_) && blessed($_) ne 'Regexp' }
 599     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
 600
 601 subtype 'Role'
 602     => as 'Object'
 603     => where { $_->can('does') }
 604     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role;
 605
 606 my $_class_name_checker = sub {};
 607
 608 subtype 'ClassName'
 609     => as 'Str'
 610     => where { Class::MOP::is_class_loaded($_) }
 611     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName;
 612
 613 subtype 'RoleName'
 614     => as 'ClassName'
 615     => where { (($_->can('meta') || return)->($_) || return)->isa('Moose::Meta::Role') }
 616     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName;    ;
 617
 618 ## --------------------------------------------------------
 619 # parameterizable types ...
 620
 621 $REGISTRY->add_type_constraint(
 622     Moose::Meta::TypeConstraint::Parameterizable->new(
 623         name                 => 'ArrayRef',
 624         package_defined_in   => __PACKAGE__,
 625         parent               => find_type_constraint('Ref'),
 626         constraint           => sub { ref($_) eq 'ARRAY'  },
 627         optimized            => \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
 628         constraint_generator => sub {
 629             my $type_parameter = shift;
 630             my $check = $type_parameter->_compiled_type_constraint;
 631             return sub {
 632                 foreach my $x (@$_) {
 633                     ($check->($x)) || return
 634                 } 1;
 635             }
 636         }
 637     )
 638 );
 639
 640 $REGISTRY->add_type_constraint(
 641     Moose::Meta::TypeConstraint::Parameterizable->new(
 642         name                 => 'HashRef',
 643         package_defined_in   => __PACKAGE__,
 644         parent               => find_type_constraint('Ref'),
 645         constraint           => sub { ref($_) eq 'HASH'  },
 646         optimized            => \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
 647         constraint_generator => sub {
 648             my $type_parameter = shift;
 649             my $check = $type_parameter->_compiled_type_constraint;
 650             return sub {
 651                 foreach my $x (values %$_) {
 652                     ($check->($x)) || return
 653                 } 1;
 654             }
 655         }
 656     )
 657 );
 658
 659 $REGISTRY->add_type_constraint(
 660     Moose::Meta::TypeConstraint::Parameterizable->new(
 661         name                 => 'Maybe',
 662         package_defined_in   => __PACKAGE__,
 663         parent               => find_type_constraint('Item'),
 664         constraint           => sub { 1 },
 665         constraint_generator => sub {
 666             my $type_parameter = shift;
 667             my $check = $type_parameter->_compiled_type_constraint;
 668             return sub {
 669                 return 1 if not(defined($_)) || $check->($_);
 670                 return;
 671             }
 672         }
 673     )
 674 );
 675
 676 my @PARAMETERIZABLE_TYPES = map {
 677     $REGISTRY->get_type_constraint($_)
 678 } qw[ArrayRef HashRef Maybe];
 679
 680 sub get_all_parameterizable_types { @PARAMETERIZABLE_TYPES }
 681 sub add_parameterizable_type {
 682     my $type = shift;
 683     (blessed $type && $type->isa('Moose::Meta::TypeConstraint::Parameterizable'))
 684         || __PACKAGE__->_throw_error("Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type");
 685     push @PARAMETERIZABLE_TYPES => $type;
 686 }
 687
 688 ## --------------------------------------------------------
 689 # end of built-in types ...
 690 ## --------------------------------------------------------
 691
 692 {
 693     my @BUILTINS = list_all_type_constraints();
 694     sub list_all_builtin_type_constraints { @BUILTINS }
 695 }
 696
 697 sub _throw_error {
 698     shift;
 699     require Moose;
 700     unshift @_, 'Moose';
 701     goto &Moose::throw_error;
 702 }
 703
 704 1;
 705
 706 __END__
 707
 708 =pod
 709
 710 =head1 NAME
 711
 712 Moose::Util::TypeConstraints - Type constraint system for Moose
 713
 714 =head1 SYNOPSIS
 715
 716   use Moose::Util::TypeConstraints;
 717
 718   type 'Num' => where { Scalar::Util::looks_like_number($_) };
 719
 720   subtype 'Natural'
 721       => as 'Int'
 722       => where { $_ > 0 };
 723
 724   subtype 'NaturalLessThanTen'
 725       => as 'Natural'
 726       => where { $_ < 10 }
 727       => message { "This number ($_) is not less than ten!" };
 728
 729   coerce 'Num'
 730       => from 'Str'
 731         => via { 0+$_ };
 732
 733   enum 'RGBColors' => qw(red green blue);
 734
 735 =head1 DESCRIPTION
 736
 737 This module provides Moose with the ability to create custom type
 738 constraints to be used in attribute definition.
 739
 740 =head2 Important Caveat
 741
 742 This is B<NOT> a type system for Perl 5. These are type constraints,
 743 and they are not used by Moose unless you tell it to. No type
 744 inference is performed, expression are not typed, etc. etc. etc.
 745
 746 This is simply a means of creating small constraint functions which
 747 can be used to simplify your own type-checking code, with the added
 748 side benefit of making your intentions clearer through self-documentation.
 749
 750 =head2 Slightly Less Important Caveat
 751
 752 It is B<always> a good idea to quote your type and subtype names.
 753
 754 This is to prevent perl from trying to execute the call as an indirect
 755 object call. This issue only seems to come up when you have a subtype
 756 the same name as a valid class, but when the issue does arise it tends
 757 to be quite annoying to debug.
 758
 759 So for instance, this:
 760
 761   subtype DateTime => as Object => where { $_->isa('DateTime') };
 762
 763 will I<Just Work>, while this:
 764
 765   use DateTime;
 766   subtype DateTime => as Object => where { $_->isa('DateTime') };
 767
 768 will fail silently and cause many headaches. The simple way to solve
 769 this, as well as future proof your subtypes from classes which have
 770 yet to have been created yet, is to simply do this:
 771
 772   use DateTime;
 773   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 774
 775 =head2 Default Type Constraints
 776
 777 This module also provides a simple hierarchy for Perl 5 types, here is
 778 that hierarchy represented visually.
 779
 780   Any
 781   Item
 782       Bool
 783       Maybe[`a]
 784       Undef
 785       Defined
 786           Value
 787               Num
 788                 Int
 789               Str
 790                 ClassName
 791                 RoleName
 792           Ref
 793               ScalarRef
 794               ArrayRef[`a]
 795               HashRef[`a]
 796               CodeRef
 797               RegexpRef
 798               GlobRef
 799                 FileHandle
 800               Object
 801                 Role
 802
 803 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 804 parameterized, this means you can say:
 805
 806   ArrayRef[Int]    # an array of integers
 807   HashRef[CodeRef] # a hash of str to CODE ref mappings
 808   Maybe[Str]       # value may be a string, may be undefined
 809
 810 If Moose finds a name in brackets that it does not recognize as an
 811 existing type, it assumes that this is a class name, for example
 812 C<ArrayRef[DateTime]>.
 813
 814 B<NOTE:> Unless you parameterize a type, then it is invalid to
 815 include the square brackets. I.e. C<ArrayRef[]> will be
 816 literally interpreted as a type name.
 817
 818 B<NOTE:> The C<Undef> type constraint for the most part works
 819 correctly now, but edge cases may still exist, please use it
 820 sparingly.
 821
 822 B<NOTE:> The C<ClassName> type constraint does a complex package
 823 existence check. This means that your class B<must> be loaded for
 824 this type constraint to pass. I know this is not ideal for all,
 825 but it is a saner restriction than most others.
 826
 827 B<NOTE:> The C<RoleName> constraint checks a string is I<package name>
 828 which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 829 constraint checks that an I<object> does the named role.
 830
 831 =head2 Type Constraint Naming
 832
 833 Type name declared via this module can only contain alphanumeric
 834 characters, colons (:), and periods (.).
 835
 836 Since the types created by this module are global, it is suggested
 837 that you namespace your types just as you would namespace your
 838 modules. So instead of creating a I<Color> type for your B<My::Graphics>
 839 module, you would call the type I<My.Graphics.Color> instead.
 840
 841 =head2 Use with Other Constraint Modules
 842
 843 This module should play fairly nicely with other constraint
 844 modules with only some slight tweaking. The C<where> clause
 845 in types is expected to be a C<CODE> reference which checks
 846 it's first argument and returns a boolean. Since most constraint
 847 modules work in a similar way, it should be simple to adapt
 848 them to work with Moose.
 849
 850 For instance, this is how you could use it with
 851 L<Declare::Constraints::Simple> to declare a completely new type.
 852
 853   type 'HashOfArrayOfObjects',
 854       {
 855       where => IsHashRef(
 856           -keys   => HasLength,
 857           -values => IsArrayRef(IsObject)
 858       )
 859   };
 860
 861 For more examples see the F<t/200_examples/204_example_w_DCS.t>
 862 test file.
 863
 864 Here is an example of using L<Test::Deep> and it's non-test
 865 related C<eq_deeply> function.
 866
 867   type 'ArrayOfHashOfBarsAndRandomNumbers'
 868       => where {
 869           eq_deeply($_,
 870               array_each(subhashof({
 871                   bar           => isa('Bar'),
 872                   random_number => ignore()
 873               })))
 874         };
 875
 876 For a complete example see the
 877 F<t/200_examples/205_example_w_TestDeep.t> test file.
 878
 879 =head1 FUNCTIONS
 880
 881 =head2 Type Constraint Constructors
 882
 883 The following functions are used to create type constraints.
 884 They will then register the type constraints in a global store
 885 where Moose can get to them if it needs to.
 886
 887 See the L<SYNOPSIS> for an example of how to use these.
 888
 889 =over 4
 890
 891 =item B<type 'Name' => where { } ... >
 892
 893 This creates a base type, which has no parent.
 894
 895 The C<type> function should either be called with the sugar helpers
 896 (C<where>, C<message>, etc), or with a name and a hashref of
 897 parameters:
 898
 899   type( 'Foo', { where => ..., message => ... } );
 900
 901 The valid hashref keys are C<where>, C<message>, and C<optimize_as>.
 902
 903 =item B<subtype 'Name' => as 'Parent' => where { } ...>
 904
 905 This creates a named subtype.
 906
 907 If you provide a parent that Moose does not recognize, it will
 908 automatically create a new class type constraint for this name.
 909
 910 When creating a named type, the C<subtype> function should either be
 911 called with the sugar helpers (C<where>, C<message>, etc), or with a
 912 name and a hashref of parameters:
 913
 914  subtype( 'Foo', { where => ..., message => ... } );
 915
 916 The valid hashref keys are C<as> (the parent), C<where>, C<message>,
 917 and C<optimize_as>.
 918
 919 =item B<subtype as 'Parent' => where { } ...>
 920
 921 This creates an unnamed subtype and will return the type
 922 constraint meta-object, which will be an instance of
 923 L<Moose::Meta::TypeConstraint>.
 924
 925 When creating an anonymous type, the C<subtype> function should either
 926 be called with the sugar helpers (C<where>, C<message>, etc), or with
 927 just a hashref of parameters:
 928
 929  subtype( { where => ..., message => ... } );
 930
 931 =item B<class_type ($class, ?$options)>
 932
 933 Creates a new subtype of C<Object> with the name C<$class> and the
 934 metaclass L<Moose::Meta::TypeConstraint::Class>.
 935
 936 =item B<role_type ($role, ?$options)>
 937
 938 Creates a C<Role> type constraint with the name C<$role> and the
 939 metaclass L<Moose::Meta::TypeConstraint::Role>.
 940
 941 =item B<maybe_type ($type)>
 942
 943 Creates a type constraint for either C<undef> or something of the
 944 given type.
 945
 946 =item B<enum ($name, @values)>
 947
 948 This will create a basic subtype for a given set of strings.
 949 The resulting constraint will be a subtype of C<Str> and
 950 will match any of the items in C<@values>. It is case sensitive.
 951 See the L<SYNOPSIS> for a simple example.
 952
 953 B<NOTE:> This is not a true proper enum type, it is simply
 954 a convenient constraint builder.
 955
 956 =item B<enum (\@values)>
 957
 958 If passed an ARRAY reference instead of the C<$name>, C<@values> pair,
 959 this will create an unnamed enum. This can then be used in an attribute
 960 definition like so:
 961
 962   has 'sort_order' => (
 963       is  => 'ro',
 964       isa => enum([qw[ ascending descending ]]),
 965   );
 966
 967 =item B<as>
 968
 969 This is just sugar for the type constraint construction syntax.
 970
 971 =item B<where>
 972
 973 This is just sugar for the type constraint construction syntax.
 974
 975 Takes a block/code ref as an argument. When the type constraint is
 976 tested, the supplied code is run with the value to be tested in
 977 $_. This block should return true or false to indicate whether or not
 978 the constraint check passed.
 979
 980 =item B<message>
 981
 982 This is just sugar for the type constraint construction syntax.
 983
 984 Takes a block/code ref as an argument. When the type constraint fails,
 985 then the code block is run (with the value provided in $_). This code
 986 ref should return a string, which will be used in the text of the
 987 exception thrown.
 988
 989 =item B<optimize_as>
 990
 991 This can be used to define a "hand optimized" version of your
 992 type constraint which can be used to avoid traversing a subtype
 993 constraint hierarchy.
 994
 995 B<NOTE:> You should only use this if you know what you are doing,
 996 all the built in types use this, so your subtypes (assuming they
 997 are shallow) will not likely need to use this.
 998
 999 =back
1000
1001 =head2 Type Coercion Constructors
1002
1003 Type constraints can also contain type coercions as well. If you
1004 ask your accessor to coerce, then Moose will run the type-coercion
1005 code first, followed by the type constraint check. This feature
1006 should be used carefully as it is very powerful and could easily
1007 take off a limb if you are not careful.
1008
1009 See the L<SYNOPSIS> for an example of how to use these.
1010
1011 =over 4
1012
1013 =item B<coerce>
1014
1015 =item B<from>
1016
1017 This is just sugar for the type coercion construction syntax.
1018
1019 =item B<via>
1020
1021 This is just sugar for the type coercion construction syntax.
1022
1023 =back
1024
1025 =head2 Type Constraint Construction & Locating
1026
1027 =over 4
1028
1029 =item B<normalize_type_constraint_name ($type_constraint_name)>
1030
1031 Given a string that is expected to match a type constraint, will normalize the
1032 string so that extra whitespace and newlines are removed.
1033
1034 =item B<create_type_constraint_union ($pipe_separated_types | @type_constraint_names)>
1035
1036 Given string with C<$pipe_separated_types> or a list of C<@type_constraint_names>,
1037 this will return a L<Moose::Meta::TypeConstraint::Union> instance.
1038
1039 =item B<create_parameterized_type_constraint ($type_name)>
1040
1041 Given a C<$type_name> in the form of:
1042
1043   BaseType[ContainerType]
1044
1045 this will extract the base type and container type and build an instance of
1046 L<Moose::Meta::TypeConstraint::Parameterized> for it.
1047
1048 =item B<create_class_type_constraint ($class, ?$options)>
1049
1050 Given a class name it will create a new L<Moose::Meta::TypeConstraint::Class>
1051 object for that class name.
1052
1053 =item B<create_role_type_constraint ($role, ?$options)>
1054
1055 Given a role name it will create a new L<Moose::Meta::TypeConstraint::Role>
1056 object for that role name.
1057
1058 =item B<create_enum_type_constraint ($name, $values)>
1059
1060 =item B<find_or_parse_type_constraint ($type_name)>
1061
1062 This will attempt to find or create a type constraint given the a C<$type_name>.
1063 If it cannot find it in the registry, it will see if it should be a union or
1064 container type an create one if appropriate
1065
1066 =item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
1067
1068 This function will first call C<find_or_parse_type_constraint> with the type name.
1069
1070 If no type is found or created, but C<$options_for_anon_type> are provided, it
1071 will create the corresponding type.
1072
1073 This was used by the C<does> and C<isa> parameters to L<Moose::Meta::Attribute>
1074 and are now superseded by C<find_or_create_isa_type_constraint> and
1075 C<find_or_create_does_type_constraint>.
1076
1077 =item B<find_or_create_isa_type_constraint ($type_name)>
1078
1079 =item B<find_or_create_does_type_constraint ($type_name)>
1080
1081 Attempts to parse the type name using C<find_or_parse_type_constraint> and if
1082 no appropriate constraint is found will create a new anonymous one.
1083
1084 The C<isa> variant will use C<create_class_type_constraint> and the C<does>
1085 variant will use C<create_role_type_constraint>.
1086
1087 =item B<find_type_constraint ($type_name)>
1088
1089 This function can be used to locate a specific type constraint
1090 meta-object, of the class L<Moose::Meta::TypeConstraint> or a
1091 derivative. What you do with it from there is up to you :)
1092
1093 =item B<register_type_constraint ($type_object)>
1094
1095 This function will register a named type constraint with the type registry.
1096
1097 =item B<get_type_constraint_registry>
1098
1099 Fetch the L<Moose::Meta::TypeConstraint::Registry> object which
1100 keeps track of all type constraints.
1101
1102 =item B<list_all_type_constraints>
1103
1104 This will return a list of type constraint names, you can then
1105 fetch them using C<find_type_constraint ($type_name)> if you
1106 want to.
1107
1108 =item B<list_all_builtin_type_constraints>
1109
1110 This will return a list of builtin type constraints, meaning,
1111 those which are defined in this module. See the section
1112 labeled L<Default Type Constraints> for a complete list.
1113
1114 =item B<export_type_constraints_as_functions>
1115
1116 This will export all the current type constraints as functions
1117 into the caller's namespace. Right now, this is mostly used for
1118 testing, but it might prove useful to others.
1119
1120 =item B<get_all_parameterizable_types>
1121
1122 This returns all the parameterizable types that have been registered.
1123
1124 =item B<add_parameterizable_type ($type)>
1125
1126 Adds C<$type> to the list of parameterizable types
1127
1128 =back
1129
1130 =head2 Namespace Management
1131
1132 =over 4
1133
1134 =item B<unimport>
1135
1136 This will remove all the type constraint keywords from the
1137 calling class namespace.
1138
1139 =back
1140
1141 =head1 BUGS
1142
1143 All complex software has bugs lurking in it, and this module is no
1144 exception. If you find a bug please either email me, or add the bug
1145 to cpan-RT.
1146
1147 =head1 AUTHOR
1148
1149 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1150
1151 =head1 COPYRIGHT AND LICENSE
1152
1153 Copyright 2006-2009 by Infinity Interactive, Inc.
1154
1155 L<http://www.iinteractive.com>
1156
1157 This library is free software; you can redistribute it and/or modify
1158 it under the same terms as Perl itself.
1159
1160 =cut