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