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     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   type 'Num' => where { Scalar::Util::looks_like_number($_) };
 723
 724   subtype 'Natural'
 725       => as 'Int'
 726       => where { $_ > 0 };
 727
 728   subtype 'NaturalLessThanTen'
 729       => as 'Natural'
 730       => where { $_ < 10 }
 731       => message { "This number ($_) is not less than ten!" };
 732
 733   coerce 'Num'
 734       => from 'Str'
 735         => via { 0+$_ };
 736
 737   enum 'RGBColors' => qw(red green blue);
 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, expression are not typed, etc. etc. etc.
 749
 750 This is simply a means of creating small constraint functions which
 751 can be used to simplify your own type-checking code, with the added
 752 side benefit of making your intentions clearer through self-documentation.
 753
 754 =head2 Slightly Less Important Caveat
 755
 756 It is B<always> a good idea to quote your type and subtype names.
 757
 758 This is to prevent perl from trying to execute the call as an indirect
 759 object call. This issue only seems to come up when you have a subtype
 760 the same name as a valid class, but when the issue does arise it tends
 761 to be quite annoying to debug.
 762
 763 So for instance, this:
 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 yet, is to simply do this:
 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
 819 include the square brackets. I.e. C<ArrayRef[]> will be
 820 literally interpreted as a type name.
 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
 828 this type constraint to pass. I know this is not ideal for all,
 829 but it is a saner restriction than most others.
 830
 831 B<NOTE:> The C<RoleName> constraint checks a string is I<package name>
 832 which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 833 constraint checks that an I<object> does the named role.
 834
 835 =head2 Type Constraint Naming
 836
 837 Type name declared via this module can only contain alphanumeric
 838 characters, colons (:), and periods (.).
 839
 840 Since the types created by this module are global, it is suggested
 841 that you namespace your types just as you would namespace your
 842 modules. So instead of creating a I<Color> type for your B<My::Graphics>
 843 module, you would call the type I<My.Graphics.Color> instead.
 844
 845 =head2 Use with Other Constraint Modules
 846
 847 This module should play fairly nicely with other constraint
 848 modules with only some slight tweaking. The C<where> clause
 849 in types is expected to be a C<CODE> reference which checks
 850 it's first argument and returns a boolean. Since most constraint
 851 modules work in a similar way, it should be simple to adapt
 852 them to work with Moose.
 853
 854 For instance, this is how you could use it with
 855 L<Declare::Constraints::Simple> to declare a completely new type.
 856
 857   type 'HashOfArrayOfObjects',
 858       {
 859       where => IsHashRef(
 860           -keys   => HasLength,
 861           -values => IsArrayRef(IsObject)
 862       )
 863   };
 864
 865 For more examples see the F<t/200_examples/204_example_w_DCS.t>
 866 test file.
 867
 868 Here is an example of using L<Test::Deep> and it's non-test
 869 related C<eq_deeply> function.
 870
 871   type 'ArrayOfHashOfBarsAndRandomNumbers'
 872       => where {
 873           eq_deeply($_,
 874               array_each(subhashof({
 875                   bar           => isa('Bar'),
 876                   random_number => ignore()
 877               })))
 878         };
 879
 880 For a complete example see the
 881 F<t/200_examples/205_example_w_TestDeep.t> test file.
 882
 883 =head1 FUNCTIONS
 884
 885 =head2 Type Constraint Constructors
 886
 887 The following functions are used to create type constraints.
 888 They will then register the type constraints in a global store
 889 where Moose can get to them if it needs to.
 890
 891 See the L<SYNOPSIS> for an example of how to use these.
 892
 893 =over 4
 894
 895 =item B<type 'Name' => where { } ... >
 896
 897 This creates a base type, which has no parent.
 898
 899 The C<type> function should either be called with the sugar helpers
 900 (C<where>, C<message>, etc), or with a name and a hashref of
 901 parameters:
 902
 903   type( 'Foo', { where => ..., message => ... } );
 904
 905 The valid hashref keys are C<where>, C<message>, and C<optimize_as>.
 906
 907 =item B<subtype 'Name' => as 'Parent' => where { } ...>
 908
 909 This creates a named subtype.
 910
 911 If you provide a parent that Moose does not recognize, it will
 912 automatically create a new class type constraint for this name.
 913
 914 When creating a named type, the C<subtype> function should either be
 915 called with the sugar helpers (C<where>, C<message>, etc), or with a
 916 name and a hashref of parameters:
 917
 918  subtype( 'Foo', { where => ..., message => ... } );
 919
 920 The valid hashref keys are C<as> (the parent), C<where>, C<message>,
 921 and C<optimize_as>.
 922
 923 =item B<subtype as 'Parent' => where { } ...>
 924
 925 This creates an unnamed subtype and will return the type
 926 constraint meta-object, which will be an instance of
 927 L<Moose::Meta::TypeConstraint>.
 928
 929 When creating an anonymous type, the C<subtype> function should either
 930 be called with the sugar helpers (C<where>, C<message>, etc), or with
 931 just a hashref of parameters:
 932
 933  subtype( { where => ..., message => ... } );
 934
 935 =item B<class_type ($class, ?$options)>
 936
 937 Creates a new subtype of C<Object> with the name C<$class> and the
 938 metaclass L<Moose::Meta::TypeConstraint::Class>.
 939
 940 =item B<role_type ($role, ?$options)>
 941
 942 Creates a C<Role> type constraint with the name C<$role> and the
 943 metaclass L<Moose::Meta::TypeConstraint::Role>.
 944
 945 =item B<maybe_type ($type)>
 946
 947 Creates a type constraint for either C<undef> or something of the
 948 given type.
 949
 950 =item B<enum ($name, @values)>
 951
 952 This will create a basic subtype for a given set of strings.
 953 The resulting constraint will be a subtype of C<Str> and
 954 will match any of the items in C<@values>. It is case sensitive.
 955 See the L<SYNOPSIS> for a simple example.
 956
 957 B<NOTE:> This is not a true proper enum type, it is simply
 958 a convenient constraint builder.
 959
 960 =item B<enum (\@values)>
 961
 962 If passed an ARRAY reference instead of the C<$name>, C<@values> pair,
 963 this will create an unnamed enum. This can then be used in an attribute
 964 definition like so:
 965
 966   has 'sort_order' => (
 967       is  => 'ro',
 968       isa => enum([qw[ ascending descending ]]),
 969   );
 970
 971 =item B<as>
 972
 973 This is just sugar for the type constraint construction syntax.
 974
 975 =item B<where>
 976
 977 This is just sugar for the type constraint construction syntax.
 978
 979 Takes a block/code ref as an argument. When the type constraint is
 980 tested, the supplied code is run with the value to be tested in
 981 $_. This block should return true or false to indicate whether or not
 982 the constraint check passed.
 983
 984 =item B<message>
 985
 986 This is just sugar for the type constraint construction syntax.
 987
 988 Takes a block/code ref as an argument. When the type constraint fails,
 989 then the code block is run (with the value provided in $_). This code
 990 ref should return a string, which will be used in the text of the
 991 exception thrown.
 992
 993 =item B<optimize_as>
 994
 995 This can be used to define a "hand optimized" version of your
 996 type constraint which can be used to avoid traversing a subtype
 997 constraint hierarchy.
 998
 999 B<NOTE:> You should only use this if you know what you are doing,
1000 all the built in types use this, so your subtypes (assuming they
1001 are shallow) will not likely need to use this.
1002
1003 =back
1004
1005 =head2 Type Coercion Constructors
1006
1007 Type constraints can also contain type coercions as well. If you
1008 ask your accessor to coerce, then Moose will run the type-coercion
1009 code first, followed by the type constraint check. This feature
1010 should be used carefully as it is very powerful and could easily
1011 take off a limb if you are not careful.
1012
1013 See the L<SYNOPSIS> for an example of how to use these.
1014
1015 =over 4
1016
1017 =item B<coerce>
1018
1019 =item B<from>
1020
1021 This is just sugar for the type coercion construction syntax.
1022
1023 =item B<via>
1024
1025 This is just sugar for the type coercion construction syntax.
1026
1027 =back
1028
1029 =head2 Type Constraint Construction & Locating
1030
1031 =over 4
1032
1033 =item B<normalize_type_constraint_name ($type_constraint_name)>
1034
1035 Given a string that is expected to match a type constraint, will normalize the
1036 string so that extra whitespace and newlines are removed.
1037
1038 =item B<create_type_constraint_union ($pipe_separated_types | @type_constraint_names)>
1039
1040 Given string with C<$pipe_separated_types> or a list of C<@type_constraint_names>,
1041 this will return a L<Moose::Meta::TypeConstraint::Union> instance.
1042
1043 =item B<create_parameterized_type_constraint ($type_name)>
1044
1045 Given a C<$type_name> in the form of:
1046
1047   BaseType[ContainerType]
1048
1049 this will extract the base type and container type and build an instance of
1050 L<Moose::Meta::TypeConstraint::Parameterized> for it.
1051
1052 =item B<create_class_type_constraint ($class, ?$options)>
1053
1054 Given a class name it will create a new L<Moose::Meta::TypeConstraint::Class>
1055 object for that class name.
1056
1057 =item B<create_role_type_constraint ($role, ?$options)>
1058
1059 Given a role name it will create a new L<Moose::Meta::TypeConstraint::Role>
1060 object for that role name.
1061
1062 =item B<create_enum_type_constraint ($name, $values)>
1063
1064 =item B<find_or_parse_type_constraint ($type_name)>
1065
1066 This will attempt to find or create a type constraint given the a C<$type_name>.
1067 If it cannot find it in the registry, it will see if it should be a union or
1068 container type an create one if appropriate
1069
1070 =item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
1071
1072 This function will first call C<find_or_parse_type_constraint> with the type name.
1073
1074 If no type is found or created, but C<$options_for_anon_type> are provided, it
1075 will create the corresponding type.
1076
1077 This was used by the C<does> and C<isa> parameters to L<Moose::Meta::Attribute>
1078 and are now superseded by C<find_or_create_isa_type_constraint> and
1079 C<find_or_create_does_type_constraint>.
1080
1081 =item B<find_or_create_isa_type_constraint ($type_name)>
1082
1083 =item B<find_or_create_does_type_constraint ($type_name)>
1084
1085 Attempts to parse the type name using C<find_or_parse_type_constraint> and if
1086 no appropriate constraint is found will create a new anonymous one.
1087
1088 The C<isa> variant will use C<create_class_type_constraint> and the C<does>
1089 variant will use C<create_role_type_constraint>.
1090
1091 =item B<find_type_constraint ($type_name)>
1092
1093 This function can be used to locate a specific type constraint
1094 meta-object, of the class L<Moose::Meta::TypeConstraint> or a
1095 derivative. What you do with it from there is up to you :)
1096
1097 =item B<register_type_constraint ($type_object)>
1098
1099 This function will register a named type constraint with the type registry.
1100
1101 =item B<get_type_constraint_registry>
1102
1103 Fetch the L<Moose::Meta::TypeConstraint::Registry> object which
1104 keeps track of all type constraints.
1105
1106 =item B<list_all_type_constraints>
1107
1108 This will return a list of type constraint names, you can then
1109 fetch them using C<find_type_constraint ($type_name)> if you
1110 want to.
1111
1112 =item B<list_all_builtin_type_constraints>
1113
1114 This will return a list of builtin type constraints, meaning,
1115 those which are defined in this module. See the section
1116 labeled L<Default Type Constraints> for a complete list.
1117
1118 =item B<export_type_constraints_as_functions>
1119
1120 This will export all the current type constraints as functions
1121 into the caller's namespace. Right now, this is mostly used for
1122 testing, but it might prove useful to others.
1123
1124 =item B<get_all_parameterizable_types>
1125
1126 This returns all the parameterizable types that have been registered.
1127
1128 =item B<add_parameterizable_type ($type)>
1129
1130 Adds C<$type> to the list of parameterizable types
1131
1132 =back
1133
1134 =head2 Namespace Management
1135
1136 =over 4
1137
1138 =item B<unimport>
1139
1140 This will remove all the type constraint keywords from the
1141 calling class namespace.
1142
1143 =back
1144
1145 =head1 BUGS
1146
1147 All complex software has bugs lurking in it, and this module is no
1148 exception. If you find a bug please either email me, or add the bug
1149 to cpan-RT.
1150
1151 =head1 AUTHOR
1152
1153 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1154
1155 =head1 COPYRIGHT AND LICENSE
1156
1157 Copyright 2006-2009 by Infinity Interactive, Inc.
1158
1159 L<http://www.iinteractive.com>
1160
1161 This library is free software; you can redistribute it and/or modify
1162 it under the same terms as Perl itself.
1163
1164 =cut