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