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