lib/Moose/Util/TypeConstraints.pm

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