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.73';
  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     if ( @_ == 1 && ! ref $_[0] ) {
 292         __PACKAGE__->_throw_error('A subtype cannot consist solely of a name, it must have a parent');
 293     }
 294
 295     # The blessed check is mostly to accommodate MooseX::Types, which
 296     # uses an object which overloads stringification as a type name.
 297     my $name = ref $_[0] && ! blessed $_[0] ? undef : shift;
 298
 299     my %p = map { %{$_} } @_;
 300
 301     # subtype Str => where { ... };
 302     if ( ! exists $p{as} ) {
 303         $p{as} = $name;
 304         $name = undef;
 305     }
 306
 307     return _create_type_constraint( $name, $p{as}, $p{where}, $p{message}, $p{optimize_as} );
 308 }
 309
 310 sub class_type {
 311     register_type_constraint(
 312         create_class_type_constraint(
 313             $_[0],
 314             ( defined($_[1]) ? $_[1] : () ),
 315         )
 316     );
 317 }
 318
 319 sub role_type ($;$) {
 320     register_type_constraint(
 321         create_role_type_constraint(
 322             $_[0],
 323             ( defined($_[1]) ? $_[1] : () ),
 324         )
 325     );
 326 }
 327
 328 sub maybe_type {
 329     my ($type_parameter) = @_;
 330
 331     register_type_constraint(
 332         $REGISTRY->get_type_constraint('Maybe')->parameterize($type_parameter)
 333     );
 334 }
 335
 336 sub coerce {
 337     my ($type_name, @coercion_map) = @_;
 338     _install_type_coercions($type_name, \@coercion_map);
 339 }
 340
 341 # The trick of returning @_ lets us avoid having to specify a
 342 # prototype. Perl will parse this:
 343 #
 344 # subtype 'Foo'
 345 #     => as 'Str'
 346 #     => where { ... }
 347 #
 348 # as this:
 349 #
 350 # subtype( 'Foo', as( 'Str', where { ... } ) );
 351 #
 352 # If as() returns all it's extra arguments, this just works, and
 353 # preserves backwards compatibility.
 354 sub as              { { as          => shift }, @_ }
 355 sub where (&)       { { where       => $_[0] } }
 356 sub message (&)     { { message     => $_[0] } }
 357 sub optimize_as (&) { { optimize_as => $_[0] } }
 358
 359 sub from    {@_}
 360 sub via (&) { $_[0] }
 361
 362 sub enum {
 363     my ($type_name, @values) = @_;
 364     # NOTE:
 365     # if only an array-ref is passed then
 366     # you get an anon-enum
 367     # - SL
 368     if (ref $type_name eq 'ARRAY' && !@values) {
 369         @values    = @$type_name;
 370         $type_name = undef;
 371     }
 372     (scalar @values >= 2)
 373         || __PACKAGE__->_throw_error("You must have at least two values to enumerate through");
 374     my %valid = map { $_ => 1 } @values;
 375
 376     register_type_constraint(
 377         create_enum_type_constraint(
 378             $type_name,
 379             \@values,
 380         )
 381     );
 382 }
 383
 384 sub create_enum_type_constraint {
 385     my ( $type_name, $values ) = @_;
 386
 387     Moose::Meta::TypeConstraint::Enum->new(
 388         name   => $type_name || '__ANON__',
 389         values => $values,
 390     );
 391 }
 392
 393 ## --------------------------------------------------------
 394 ## desugaring functions ...
 395 ## --------------------------------------------------------
 396
 397 sub _create_type_constraint ($$$;$$) {
 398     my $name      = shift;
 399     my $parent    = shift;
 400     my $check     = shift;
 401     my $message   = shift;
 402     my $optimized = shift;
 403
 404     my $pkg_defined_in = scalar( caller(1) );
 405
 406     if ( defined $name ) {
 407         my $type = $REGISTRY->get_type_constraint($name);
 408
 409         ( $type->_package_defined_in eq $pkg_defined_in )
 410             || _confess(
 411                   "The type constraint '$name' has already been created in "
 412                 . $type->_package_defined_in
 413                 . " and cannot be created again in "
 414                 . $pkg_defined_in )
 415             if defined $type;
 416
 417         $name =~ /^[\w:\.]+$/
 418             or die qq{$name contains invalid characters for a type name.}
 419             . qq{ Names can contain alphanumeric character, ":", and "."\n};
 420     }
 421
 422     my %opts = (
 423         name               => $name,
 424         package_defined_in => $pkg_defined_in,
 425
 426         ( $check     ? ( constraint => $check )     : () ),
 427         ( $message   ? ( message    => $message )   : () ),
 428         ( $optimized ? ( optimized  => $optimized ) : () ),
 429     );
 430
 431     my $constraint;
 432     if ( defined $parent
 433         and $parent
 434         = blessed $parent ? $parent : find_or_create_isa_type_constraint($parent) )
 435     {
 436         $constraint = $parent->create_child_type(%opts);
 437     }
 438     else {
 439         $constraint = Moose::Meta::TypeConstraint->new(%opts);
 440     }
 441
 442     $REGISTRY->add_type_constraint($constraint)
 443         if defined $name;
 444
 445     return $constraint;
 446 }
 447
 448 sub _install_type_coercions ($$) {
 449     my ($type_name, $coercion_map) = @_;
 450     my $type = find_type_constraint($type_name);
 451     (defined $type)
 452         || __PACKAGE__->_throw_error("Cannot find type '$type_name', perhaps you forgot to load it.");
 453     if ($type->has_coercion) {
 454         $type->coercion->add_type_coercions(@$coercion_map);
 455     }
 456     else {
 457         my $type_coercion = Moose::Meta::TypeCoercion->new(
 458             type_coercion_map => $coercion_map,
 459             type_constraint   => $type
 460         );
 461         $type->coercion($type_coercion);
 462     }
 463 }
 464
 465 ## --------------------------------------------------------
 466 ## type notation parsing ...
 467 ## --------------------------------------------------------
 468
 469 {
 470     # All I have to say is mugwump++ cause I know
 471     # do not even have enough regexp-fu to be able
 472     # to have written this (I can only barely
 473     # understand it as it is)
 474     # - SL
 475
 476     use re "eval";
 477
 478     my $valid_chars = qr{[\w:\.]};
 479     my $type_atom   = qr{ $valid_chars+ };
 480
 481     my $any;
 482
 483     my $type                = qr{  $valid_chars+  (?: \[ \s* (??{$any})   \s* \] )? }x;
 484     my $type_capture_parts  = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x;
 485     my $type_with_parameter = qr{  $valid_chars+      \[ \s* (??{$any})   \s* \]    }x;
 486
 487     my $op_union = qr{ \s* \| \s* }x;
 488     my $union    = qr{ $type (?: $op_union $type )+ }x;
 489
 490     $any = qr{ $type | $union }x;
 491
 492     sub _parse_parameterized_type_constraint {
 493         { no warnings 'void'; $any; } # force capture of interpolated lexical
 494         $_[0] =~ m{ $type_capture_parts }x;
 495         return ($1, $2);
 496     }
 497
 498     sub _detect_parameterized_type_constraint {
 499         { no warnings 'void'; $any; } # force capture of interpolated lexical
 500         $_[0] =~ m{ ^ $type_with_parameter $ }x;
 501     }
 502
 503     sub _parse_type_constraint_union {
 504         { no warnings 'void'; $any; } # force capture of interpolated lexical
 505         my $given = shift;
 506         my @rv;
 507         while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
 508             push @rv => $1;
 509         }
 510         (pos($given) eq length($given))
 511             || __PACKAGE__->_throw_error("'$given' didn't parse (parse-pos="
 512                      . pos($given)
 513                      . " and str-length="
 514                      . length($given)
 515                      . ")");
 516         @rv;
 517     }
 518
 519     sub _detect_type_constraint_union {
 520         { no warnings 'void'; $any; } # force capture of interpolated lexical
 521         $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
 522     }
 523 }
 524
 525 ## --------------------------------------------------------
 526 # define some basic built-in types
 527 ## --------------------------------------------------------
 528
 529 # By making these classes immutable before creating all the types we
 530 # below, we avoid repeatedly calling the slow MOP-based accessors.
 531 $_->make_immutable(
 532     inline_constructor => 1,
 533     constructor_name   => "_new",
 534
 535     # these are Class::MOP accessors, so they need inlining
 536     inline_accessors => 1
 537     ) for grep { $_->is_mutable }
 538     map { $_->meta }
 539     qw(
 540     Moose::Meta::TypeConstraint
 541     Moose::Meta::TypeConstraint::Union
 542     Moose::Meta::TypeConstraint::Parameterized
 543     Moose::Meta::TypeConstraint::Parameterizable
 544     Moose::Meta::TypeConstraint::Class
 545     Moose::Meta::TypeConstraint::Role
 546     Moose::Meta::TypeConstraint::Enum
 547     Moose::Meta::TypeConstraint::Registry
 548 );
 549
 550 type 'Any'  => where { 1 }; # meta-type including all
 551 type 'Item' => where { 1 }; # base-type
 552
 553 subtype 'Undef'   => as 'Item' => where { !defined($_) };
 554 subtype 'Defined' => as 'Item' => where {  defined($_) };
 555
 556 subtype 'Bool'
 557     => as 'Item'
 558     => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
 559
 560 subtype 'Value'
 561     => as 'Defined'
 562     => where { !ref($_) }
 563     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Value;
 564
 565 subtype 'Ref'
 566     => as 'Defined'
 567     => where {  ref($_) }
 568     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref;
 569
 570 subtype 'Str'
 571     => as 'Value'
 572     => where { 1 }
 573     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str;
 574
 575 subtype 'Num'
 576     => as 'Value'
 577     => where { Scalar::Util::looks_like_number($_) }
 578     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Num;
 579
 580 subtype 'Int'
 581     => as 'Num'
 582     => where { "$_" =~ /^-?[0-9]+$/ }
 583     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
 584
 585 subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef;
 586 subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
 587 subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
 588 subtype 'GlobRef'   => as 'Ref' => where { ref($_) eq 'GLOB'   } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
 589
 590 # NOTE:
 591 # scalar filehandles are GLOB refs,
 592 # but a GLOB ref is not always a filehandle
 593 subtype 'FileHandle'
 594     => as 'GlobRef'
 595     => where { Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") ) }
 596     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
 597
 598 # NOTE:
 599 # blessed(qr/.../) returns true,.. how odd
 600 subtype 'Object'
 601     => as 'Ref'
 602     => where { blessed($_) && blessed($_) ne 'Regexp' }
 603     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
 604
 605 subtype 'Role'
 606     => as 'Object'
 607     => where { $_->can('does') }
 608     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role;
 609
 610 my $_class_name_checker = sub {};
 611
 612 subtype 'ClassName'
 613     => as 'Str'
 614     => where { Class::MOP::is_class_loaded($_) }
 615     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName;
 616
 617 subtype 'RoleName'
 618     => as 'ClassName'
 619     => where { (($_->can('meta') || return)->($_) || return)->isa('Moose::Meta::Role') }
 620     => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName;    ;
 621
 622 ## --------------------------------------------------------
 623 # parameterizable types ...
 624
 625 $REGISTRY->add_type_constraint(
 626     Moose::Meta::TypeConstraint::Parameterizable->new(
 627         name                 => 'ArrayRef',
 628         package_defined_in   => __PACKAGE__,
 629         parent               => find_type_constraint('Ref'),
 630         constraint           => sub { ref($_) eq 'ARRAY'  },
 631         optimized            => \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
 632         constraint_generator => sub {
 633             my $type_parameter = shift;
 634             my $check = $type_parameter->_compiled_type_constraint;
 635             return sub {
 636                 foreach my $x (@$_) {
 637                     ($check->($x)) || return
 638                 } 1;
 639             }
 640         }
 641     )
 642 );
 643
 644 $REGISTRY->add_type_constraint(
 645     Moose::Meta::TypeConstraint::Parameterizable->new(
 646         name                 => 'HashRef',
 647         package_defined_in   => __PACKAGE__,
 648         parent               => find_type_constraint('Ref'),
 649         constraint           => sub { ref($_) eq 'HASH'  },
 650         optimized            => \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
 651         constraint_generator => sub {
 652             my $type_parameter = shift;
 653             my $check = $type_parameter->_compiled_type_constraint;
 654             return sub {
 655                 foreach my $x (values %$_) {
 656                     ($check->($x)) || return
 657                 } 1;
 658             }
 659         }
 660     )
 661 );
 662
 663 $REGISTRY->add_type_constraint(
 664     Moose::Meta::TypeConstraint::Parameterizable->new(
 665         name                 => 'Maybe',
 666         package_defined_in   => __PACKAGE__,
 667         parent               => find_type_constraint('Item'),
 668         constraint           => sub { 1 },
 669         constraint_generator => sub {
 670             my $type_parameter = shift;
 671             my $check = $type_parameter->_compiled_type_constraint;
 672             return sub {
 673                 return 1 if not(defined($_)) || $check->($_);
 674                 return;
 675             }
 676         }
 677     )
 678 );
 679
 680 my @PARAMETERIZABLE_TYPES = map {
 681     $REGISTRY->get_type_constraint($_)
 682 } qw[ArrayRef HashRef Maybe];
 683
 684 sub get_all_parameterizable_types { @PARAMETERIZABLE_TYPES }
 685 sub add_parameterizable_type {
 686     my $type = shift;
 687     (blessed $type && $type->isa('Moose::Meta::TypeConstraint::Parameterizable'))
 688         || __PACKAGE__->_throw_error("Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type");
 689     push @PARAMETERIZABLE_TYPES => $type;
 690 }
 691
 692 ## --------------------------------------------------------
 693 # end of built-in types ...
 694 ## --------------------------------------------------------
 695
 696 {
 697     my @BUILTINS = list_all_type_constraints();
 698     sub list_all_builtin_type_constraints { @BUILTINS }
 699 }
 700
 701 sub _throw_error {
 702     shift;
 703     require Moose;
 704     unshift @_, 'Moose';
 705     goto &Moose::throw_error;
 706 }
 707
 708 1;
 709
 710 __END__
 711
 712 =pod
 713
 714 =head1 NAME
 715
 716 Moose::Util::TypeConstraints - Type constraint system for Moose
 717
 718 =head1 SYNOPSIS
 719
 720   use Moose::Util::TypeConstraints;
 721
 722   subtype 'Natural'
 723       => as 'Int'
 724       => where { $_ > 0 };
 725
 726   subtype 'NaturalLessThanTen'
 727       => as 'Natural'
 728       => where { $_ < 10 }
 729       => message { "This number ($_) is not less than ten!" };
 730
 731   coerce 'Num'
 732       => from 'Str'
 733         => via { 0+$_ };
 734
 735   enum 'RGBColors' => qw(red green blue);
 736
 737   no Moose::Util::TypeConstraints;
 738
 739 =head1 DESCRIPTION
 740
 741 This module provides Moose with the ability to create custom type
 742 constraints to be used in attribute definition.
 743
 744 =head2 Important Caveat
 745
 746 This is B<NOT> a type system for Perl 5. These are type constraints,
 747 and they are not used by Moose unless you tell it to. No type
 748 inference is performed, expressions are not typed, etc. etc. etc.
 749
 750 A type constraint is at heart a small "check if a value is valid"
 751 function. A constraint can be associated with an attribute. This
 752 simplifies parameter validation, and makes your code clearer to read,
 753 because you can refer to constraints by name.
 754
 755 =head2 Slightly Less Important Caveat
 756
 757 It is B<always> a good idea to quote your type names.
 758
 759 This prevents Perl from trying to execute the call as an indirect
 760 object call. This can be an issue when you have a subtype with the
 761 same name as a valid class.
 762
 763 For instance:
 764
 765   subtype DateTime => as Object => where { $_->isa('DateTime') };
 766
 767 will I<just work>, while this:
 768
 769   use DateTime;
 770   subtype DateTime => as Object => where { $_->isa('DateTime') };
 771
 772 will fail silently and cause many headaches. The simple way to solve
 773 this, as well as future proof your subtypes from classes which have
 774 yet to have been created, is to quote the type name:
 775
 776   use DateTime;
 777   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 778
 779 =head2 Default Type Constraints
 780
 781 This module also provides a simple hierarchy for Perl 5 types, here is
 782 that hierarchy represented visually.
 783
 784   Any
 785   Item
 786       Bool
 787       Maybe[`a]
 788       Undef
 789       Defined
 790           Value
 791               Num
 792                 Int
 793               Str
 794                 ClassName
 795                 RoleName
 796           Ref
 797               ScalarRef
 798               ArrayRef[`a]
 799               HashRef[`a]
 800               CodeRef
 801               RegexpRef
 802               GlobRef
 803                 FileHandle
 804               Object
 805                 Role
 806
 807 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 808 parameterized, this means you can say:
 809
 810   ArrayRef[Int]    # an array of integers
 811   HashRef[CodeRef] # a hash of str to CODE ref mappings
 812   Maybe[Str]       # value may be a string, may be undefined
 813
 814 If Moose finds a name in brackets that it does not recognize as an
 815 existing type, it assumes that this is a class name, for example
 816 C<ArrayRef[DateTime]>.
 817
 818 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 819 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 820 name, I<not> as a parameterization of C<ArrayRef>.
 821
 822 B<NOTE:> The C<Undef> type constraint for the most part works
 823 correctly now, but edge cases may still exist, please use it
 824 sparingly.
 825
 826 B<NOTE:> The C<ClassName> type constraint does a complex package
 827 existence check. This means that your class B<must> be loaded for this
 828 type constraint to pass.
 829
 830 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 831 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 832 constraint checks that an I<object does> the named role.
 833
 834 =head2 Type Constraint Naming
 835
 836 Type name declared via this module can only contain alphanumeric
 837 characters, colons (:), and periods (.).
 838
 839 Since the types created by this module are global, it is suggested
 840 that you namespace your types just as you would namespace your
 841 modules. So instead of creating a I<Color> type for your
 842 B<My::Graphics> module, you would call the type
 843 I<My::Graphics::Types::Color> instead.
 844
 845 =head2 Use with Other Constraint Modules
 846
 847 This module can play nicely with other constraint modules with some
 848 slight tweaking. The C<where> clause in types is expected to be a
 849 C<CODE> reference which checks it's first argument and returns a
 850 boolean. Since most constraint modules work in a similar way, it
 851 should be simple to adapt them to work with Moose.
 852
 853 For instance, this is how you could use it with
 854 L<Declare::Constraints::Simple> to declare a completely new type.
 855
 856   type 'HashOfArrayOfObjects',
 857       {
 858       where => IsHashRef(
 859           -keys   => HasLength,
 860           -values => IsArrayRef(IsObject)
 861       )
 862   };
 863
 864 For more examples see the F<t/200_examples/004_example_w_DCS.t> test
 865 file.
 866
 867 Here is an example of using L<Test::Deep> and it's non-test
 868 related C<eq_deeply> function.
 869
 870   type 'ArrayOfHashOfBarsAndRandomNumbers'
 871       => where {
 872           eq_deeply($_,
 873               array_each(subhashof({
 874                   bar           => isa('Bar'),
 875                   random_number => ignore()
 876               })))
 877         };
 878
 879 For a complete example see the
 880 F<t/200_examples/005_example_w_TestDeep.t> test file.
 881
 882 =head1 FUNCTIONS
 883
 884 =head2 Type Constraint Constructors
 885
 886 The following functions are used to create type constraints.  They
 887 will also register the type constraints your create in a global
 888 registry that is used to look types up by name.
 889
 890 See the L<SYNOPSIS> for an example of how to use these.
 891
 892 =over 4
 893
 894 =item B<subtype 'Name' => as 'Parent' => where { } ...>
 895
 896 This creates a named subtype.
 897
 898 If you provide a parent that Moose does not recognize, it will
 899 automatically create a new class type constraint for this name.
 900
 901 When creating a named type, the C<subtype> function should either be
 902 called with the sugar helpers (C<where>, C<message>, etc), or with a
 903 name and a hashref of parameters:
 904
 905  subtype( 'Foo', { where => ..., message => ... } );
 906
 907 The valid hashref keys are C<as> (the parent), C<where>, C<message>,
 908 and C<optimize_as>.
 909
 910 =item B<subtype as 'Parent' => where { } ...>
 911
 912 This creates an unnamed subtype and will return the type
 913 constraint meta-object, which will be an instance of
 914 L<Moose::Meta::TypeConstraint>.
 915
 916 When creating an anonymous type, the C<subtype> function should either
 917 be called with the sugar helpers (C<where>, C<message>, etc), or with
 918 just a hashref of parameters:
 919
 920  subtype( { where => ..., message => ... } );
 921
 922 =item B<class_type ($class, ?$options)>
 923
 924 Creates a new subtype of C<Object> with the name C<$class> and the
 925 metaclass L<Moose::Meta::TypeConstraint::Class>.
 926
 927 =item B<role_type ($role, ?$options)>
 928
 929 Creates a C<Role> type constraint with the name C<$role> and the
 930 metaclass L<Moose::Meta::TypeConstraint::Role>.
 931
 932 =item B<maybe_type ($type)>
 933
 934 Creates a type constraint for either C<undef> or something of the
 935 given type.
 936
 937 =item B<enum ($name, @values)>
 938
 939 This will create a basic subtype for a given set of strings.
 940 The resulting constraint will be a subtype of C<Str> and
 941 will match any of the items in C<@values>. It is case sensitive.
 942 See the L<SYNOPSIS> for a simple example.
 943
 944 B<NOTE:> This is not a true proper enum type, it is simply
 945 a convenient constraint builder.
 946
 947 =item B<enum (\@values)>
 948
 949 If passed an ARRAY reference instead of the C<$name>, C<@values> pair,
 950 this will create an unnamed enum. This can then be used in an attribute
 951 definition like so:
 952
 953   has 'sort_order' => (
 954       is  => 'ro',
 955       isa => enum([qw[ ascending descending ]]),
 956   );
 957
 958 =item B<as 'Parent'>
 959
 960 This is just sugar for the type constraint construction syntax.
 961
 962 It takes a single argument, which is the name of a parent type.
 963
 964 =item B<where { ... }>
 965
 966 This is just sugar for the type constraint construction syntax.
 967
 968 It takes a subroutine reference as an argument. When the type
 969 constraint is tested, the reference is run with the value to be tested
 970 in C<$_>. This reference should return true or false to indicate
 971 whether or not the constraint check passed.
 972
 973 =item B<message { ... }>
 974
 975 This is just sugar for the type constraint construction syntax.
 976
 977 It takes a subroutine reference as an argument. When the type
 978 constraint fails, then the code block is run with the value provided
 979 in C<$_>. This reference should return a string, which will be used in
 980 the text of the exception thrown.
 981
 982 =item B<optimize_as { ... }>
 983
 984 This can be used to define a "hand optimized" version of your
 985 type constraint which can be used to avoid traversing a subtype
 986 constraint hierarchy.
 987
 988 B<NOTE:> You should only use this if you know what you are doing,
 989 all the built in types use this, so your subtypes (assuming they
 990 are shallow) will not likely need to use this.
 991
 992 =item B<type 'Name' => where { } ... >
 993
 994 This creates a base type, which has no parent.
 995
 996 The C<type> function should either be called with the sugar helpers
 997 (C<where>, C<message>, etc), or with a name and a hashref of
 998 parameters:
 999
1000   type( 'Foo', { where => ..., message => ... } );
1001
1002 The valid hashref keys are C<where>, C<message>, and C<optimize_as>.
1003
1004 =back
1005
1006 =head2 Type Coercion Constructors
1007
1008 You can define coercions for type constraints, which allow you to
1009 automatically transform values to something valid for the type
1010 constraint. If you ask your accessor to coerce, then Moose will run
1011 the type-coercion code first, followed by the type constraint
1012 check. This feature should be used carefully as it is very powerful
1013 and could easily take off a limb if you are not careful.
1014
1015 See the L<SYNOPSIS> for an example of how to use these.
1016
1017 =over 4
1018
1019 =item B<< coerce 'Name' => from 'OtherName' => via { ... } >>
1020
1021 This defines a coercion from one type to another. The C<Name> argument
1022 is the type you are coercing I<to>.
1023
1024 =item B<from 'OtherName'>
1025
1026 This is just sugar for the type coercion construction syntax.
1027
1028 It takes a single type name (or type object), which is the type being
1029 coerced I<from>.
1030
1031 =item B<via { ... }>
1032
1033 This is just sugar for the type coercion construction syntax.
1034
1035 It takes a subroutine reference. This reference will be called with
1036 the value to be coerced in C<$_>. It is expected to return a new value
1037 of the proper type for the coercion.
1038
1039 =back
1040
1041 =head2 Creating and Finding Type Constraints
1042
1043 These are additional functions for creating and finding type
1044 constraints. Most of these functions are not available for
1045 importing. The ones that are importable as specified.
1046
1047 =over 4
1048
1049 =item B<find_type_constraint($type_name)>
1050
1051 This function can be used to locate the L<Moose::Meta::TypeConstraint>
1052 object for a named type.
1053
1054 This function is importable.
1055
1056 =item B<register_type_constraint($type_object)>
1057
1058 This function will register a L<Moose::Meta::TypeConstraint> with the
1059 global type registry.
1060
1061 This function is importable.
1062
1063 =item B<normalize_type_constraint_name($type_constraint_name)>
1064
1065 This method takes a type constraint name and returns the normalized
1066 form. This removes any whitespace in the string.
1067
1068 =item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)>
1069
1070 This can take a union type specification like C<'Int|ArrayRef[Int]'>,
1071 or a list of names. It returns a new
1072 L<Moose::Meta::TypeConstraint::Union> object.
1073
1074 =item B<create_parameterized_type_constraint($type_name)>
1075
1076 Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>,
1077 this will create a new L<Moose::Meta::TypeConstraint::Parameterized>
1078 object. The C<BaseType> must exist already exist as a parameterizable
1079 type.
1080
1081 =item B<create_class_type_constraint($class, $options)>
1082
1083 Given a class name this function will create a new
1084 L<Moose::Meta::TypeConstraint::Class> object for that class name.
1085
1086 The C<$options> is a hash reference that will be passed to the
1087 L<Moose::Meta::TypeConstraint::Class> constructor (as a hash).
1088
1089 =item B<create_role_type_constraint($role, $options)>
1090
1091 Given a role name this function will create a new
1092 L<Moose::Meta::TypeConstraint::Role> object for that role name.
1093
1094 The C<$options> is a hash reference that will be passed to the
1095 L<Moose::Meta::TypeConstraint::Role> constructor (as a hash).
1096
1097 =item B<create_enum_type_constraint($name, $values)>
1098
1099 Given a enum name this function will create a new
1100 L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
1101
1102 =item B<find_or_parse_type_constraint($type_name)>
1103
1104 Given a type name, this first attempts to find a matching constraint
1105 in the global registry.
1106
1107 If the type name is a union or parameterized type, it will create a
1108 new object of the appropriate, but if given a "regular" type that does
1109 not yet exist, it simply returns false.
1110
1111 When given a union or parameterized type, the member or base type must
1112 already exist.
1113
1114 If it creates a new union or parameterized type, it will add it to the
1115 global registry.
1116
1117 =item B<find_or_create_isa_type_constraint($type_name)>
1118
1119 =item B<find_or_create_does_type_constraint($type_name)>
1120
1121 These functions will first call C<find_or_parse_type_constraint>. If
1122 that function does not return a type, a new anonymous type object will
1123 be created.
1124
1125 The C<isa> variant will use C<create_class_type_constraint> and the
1126 C<does> variant will use C<create_role_type_constraint>.
1127
1128 =item B<get_type_constraint_registry>
1129
1130 Returns the L<Moose::Meta::TypeConstraint::Registry> object which
1131 keeps track of all type constraints.
1132
1133 =item B<list_all_type_constraints>
1134
1135 This will return a list of type constraint names in the global
1136 registry. You can then fetch the actual type object using
1137 C<find_type_constraint($type_name)>.
1138
1139 =item B<list_all_builtin_type_constraints>
1140
1141 This will return a list of builtin type constraints, meaning those
1142 which are defined in this module. See the L<Default Type Constraints>
1143 section for a complete list.
1144
1145 =item B<export_type_constraints_as_functions>
1146
1147 This will export all the current type constraints as functions into
1148 the caller's namespace (C<Int()>, C<Str()>, etc). Right now, this is
1149 mostly used for testing, but it might prove useful to others.
1150
1151 =item B<get_all_parameterizable_types>
1152
1153 This returns all the parameterizable types that have been registered,
1154 as a list of type objects.
1155
1156 =item B<add_parameterizable_type($type)>
1157
1158 Adds C<$type> to the list of parameterizable types
1159
1160 =back
1161
1162 =head1 BUGS
1163
1164 All complex software has bugs lurking in it, and this module is no
1165 exception. If you find a bug please either email me, or add the bug
1166 to cpan-RT.
1167
1168 =head1 AUTHOR
1169
1170 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1171
1172 =head1 COPYRIGHT AND LICENSE
1173
1174 Copyright 2006-2009 by Infinity Interactive, Inc.
1175
1176 L<http://www.iinteractive.com>
1177
1178 This library is free software; you can redistribute it and/or modify
1179 it under the same terms as Perl itself.
1180
1181 =cut