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