lib/Moose/Util/TypeConstraints.pm

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