merge trunk to pluggable errors
[gitmo/Moose.git] / lib / Moose / Util / TypeConstraints.pm
CommitLineData
a15dff8d 1
2package Moose::Util::TypeConstraints;
3
4use strict;
5use warnings;
6
998a8a25 7use Carp ();
21f1e231 8use Scalar::Util 'blessed';
e606ae5f 9use Moose::Exporter;
a15dff8d 10
e606ae5f 11our $VERSION = '0.57';
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
e606ae5f 66Moose::Exporter->setup_import_methods(
67 as_is => [
68 qw(
69 type subtype class_type role_type as where message optimize_as
70 coerce from via
71 enum
72 find_type_constraint
73 register_type_constraint )
74 ],
75 _export_to_main => 1,
76);
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
998a8a25 84sub confess {
85 my ($msg, @args) = @_;
86
87 my $caller = caller(2);
88 if ( $caller->can("meta") and my $throw = $caller->meta->can("throw_error") ) {
89 goto $throw;
90 } else {
91 @_ = $msg;
92 goto &Carp::confess;
93 }
94}
95
d9b40005 96sub get_type_constraint_registry { $REGISTRY }
e85d2a5d 97sub list_all_type_constraints { keys %{$REGISTRY->type_constraints} }
d9b40005 98sub export_type_constraints_as_functions {
99 my $pkg = caller();
100 no strict 'refs';
a0f8153d 101 foreach my $constraint (keys %{$REGISTRY->type_constraints}) {
42bc21a4 102 my $tc = $REGISTRY->get_type_constraint($constraint)->_compiled_type_constraint;
d2f0f6e9 103 *{"${pkg}::${constraint}"} = sub { $tc->($_[0]) ? 1 : undef }; # the undef is for compat
a0f8153d 104 }
d9b40005 105}
182134e8 106
d9b40005 107sub create_type_constraint_union (@) {
108 my @type_constraint_names;
e85d2a5d 109
f1917f58 110 if (scalar @_ == 1 && _detect_type_constraint_union($_[0])) {
111 @type_constraint_names = _parse_type_constraint_union($_[0]);
d9b40005 112 }
113 else {
114 @type_constraint_names = @_;
429ccc11 115 }
e85d2a5d 116
3726f905 117 (scalar @type_constraint_names >= 2)
e85d2a5d 118 || confess "You must pass in at least 2 type names to make a union";
119
d9b40005 120 ($REGISTRY->has_type_constraint($_))
121 || confess "Could not locate type constraint ($_) for the union"
122 foreach @type_constraint_names;
e85d2a5d 123
3726f905 124 return Moose::Meta::TypeConstraint::Union->new(
125 type_constraints => [
e85d2a5d 126 map {
127 $REGISTRY->get_type_constraint($_)
128 } @type_constraint_names
3726f905 129 ],
e85d2a5d 130 );
182134e8 131}
a15dff8d 132
0fbd4b0a 133sub create_parameterized_type_constraint ($) {
d9b40005 134 my $type_constraint_name = shift;
e85d2a5d 135
0fbd4b0a 136 my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name);
e85d2a5d 137
0fbd4b0a 138 (defined $base_type && defined $type_parameter)
d9b40005 139 || confess "Could not parse type name ($type_constraint_name) correctly";
e85d2a5d 140
d9b40005 141 ($REGISTRY->has_type_constraint($base_type))
142 || confess "Could not locate the base type ($base_type)";
e85d2a5d 143
0fbd4b0a 144 return Moose::Meta::TypeConstraint::Parameterized->new(
d9b40005 145 name => $type_constraint_name,
146 parent => $REGISTRY->get_type_constraint($base_type),
620db045 147 type_parameter => find_or_create_isa_type_constraint($type_parameter),
e85d2a5d 148 );
22aed3c0 149}
150
4ab662d6 151#should we also support optimized checks?
152sub create_class_type_constraint ($;$) {
620db045 153 my ( $class, $options ) = @_;
154
3fef8ce8 155 # too early for this check
156 #find_type_constraint("ClassName")->check($class)
157 # || confess "Can't create a class type constraint because '$class' is not a class name";
158
620db045 159 my %options = (
160 class => $class,
161 name => $class,
162 %{ $options || {} },
4ab662d6 163 );
620db045 164
165 $options{name} ||= "__ANON__";
166
167 Moose::Meta::TypeConstraint::Class->new( %options );
3fef8ce8 168}
169
620db045 170sub create_role_type_constraint ($;$) {
171 my ( $role, $options ) = @_;
e85d2a5d 172
620db045 173 # too early for this check
174 #find_type_constraint("ClassName")->check($class)
175 # || confess "Can't create a class type constraint because '$class' is not a class name";
e85d2a5d 176
620db045 177 my %options = (
178 role => $role,
179 name => $role,
180 %{ $options || {} },
181 );
e85d2a5d 182
620db045 183 $options{name} ||= "__ANON__";
184
185 Moose::Meta::TypeConstraint::Role->new( %options );
186}
187
188
189sub find_or_create_type_constraint ($;$) {
190 my ( $type_constraint_name, $options_for_anon_type ) = @_;
191
192 if ( my $constraint = find_or_parse_type_constraint($type_constraint_name) ) {
193 return $constraint;
d9b40005 194 }
620db045 195 elsif ( defined $options_for_anon_type ) {
d9b40005 196 # NOTE:
4ab662d6 197 # if there is no $options_for_anon_type
198 # specified, then we assume they don't
f3c4e20e 199 # want to create one, and return nothing.
f3c4e20e 200
d9b40005 201 # otherwise assume that we should create
e85d2a5d 202 # an ANON type with the $options_for_anon_type
d9b40005 203 # options which can be passed in. It should
e85d2a5d 204 # be noted that these don't get registered
d9b40005 205 # so we need to return it.
206 # - SL
207 return Moose::Meta::TypeConstraint->new(
208 name => '__ANON__',
e85d2a5d 209 %{$options_for_anon_type}
d9b40005 210 );
211 }
e85d2a5d 212
620db045 213 return;
214}
215
216sub find_or_create_isa_type_constraint ($) {
217 my $type_constraint_name = shift;
5e2ada84 218 find_or_parse_type_constraint($type_constraint_name) || create_class_type_constraint($type_constraint_name)
620db045 219}
220
221sub find_or_create_does_type_constraint ($) {
222 my $type_constraint_name = shift;
5e2ada84 223 find_or_parse_type_constraint($type_constraint_name) || create_role_type_constraint($type_constraint_name)
620db045 224}
225
226sub find_or_parse_type_constraint ($) {
227 my $type_constraint_name = shift;
620db045 228 my $constraint;
e606ae5f 229
230 if ($constraint = find_type_constraint($type_constraint_name)) {
231 return $constraint;
232 } elsif (_detect_type_constraint_union($type_constraint_name)) {
620db045 233 $constraint = create_type_constraint_union($type_constraint_name);
e606ae5f 234 } elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
620db045 235 $constraint = create_parameterized_type_constraint($type_constraint_name);
236 } else {
237 return;
238 }
e606ae5f 239
d9b40005 240 $REGISTRY->add_type_constraint($constraint);
e85d2a5d 241 return $constraint;
d9b40005 242}
22aed3c0 243
244## --------------------------------------------------------
245## exported functions ...
246## --------------------------------------------------------
247
eeedfc8a 248sub find_type_constraint ($) {
249 my $type = shift;
250
251 if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) {
252 return $type;
e606ae5f 253 }
254 else {
255 return unless $REGISTRY->has_type_constraint($type);
eeedfc8a 256 return $REGISTRY->get_type_constraint($type);
257 }
258}
22aed3c0 259
3fef8ce8 260sub register_type_constraint ($) {
261 my $constraint = shift;
262 confess "can't register an unnamed type constraint" unless defined $constraint->name;
263 $REGISTRY->add_type_constraint($constraint);
dabed765 264 return $constraint;
3fef8ce8 265}
266
7c13858b 267# type constructors
a15dff8d 268
815ec671 269sub type ($$;$$) {
1b7df21f 270 splice(@_, 1, 0, undef);
a0f8153d 271 goto &_create_type_constraint;
a15dff8d 272}
273
8ecb1fa0 274sub subtype ($$;$$$) {
86629f93 275 # NOTE:
276 # this adds an undef for the name
277 # if this is an anon-subtype:
278 # subtype(Num => where { $_ % 2 == 0 }) # anon 'even' subtype
279 # but if the last arg is not a code
280 # ref then it is a subtype alias:
281 # subtype(MyNumbers => as Num); # now MyNumbers is the same as Num
e85d2a5d 282 # ... yeah I know it's ugly code
86629f93 283 # - SL
21f1e231 284 unshift @_ => undef if scalar @_ <= 2 && ('CODE' eq ref($_[1]));
a0f8153d 285 goto &_create_type_constraint;
a15dff8d 286}
287
4ab662d6 288sub class_type ($;$) {
289 register_type_constraint(
290 create_class_type_constraint(
291 $_[0],
292 ( defined($_[1]) ? $_[1] : () ),
293 )
294 );
3fef8ce8 295}
296
620db045 297sub role_type ($;$) {
298 register_type_constraint(
299 create_role_type_constraint(
300 $_[0],
301 ( defined($_[1]) ? $_[1] : () ),
302 )
303 );
304}
305
4b598ea3 306sub coerce ($@) {
e85d2a5d 307 my ($type_name, @coercion_map) = @_;
7c13858b 308 _install_type_coercions($type_name, \@coercion_map);
182134e8 309}
310
76d37e5a 311sub as ($) { $_[0] }
312sub from ($) { $_[0] }
313sub where (&) { $_[0] }
314sub via (&) { $_[0] }
8ecb1fa0 315
316sub message (&) { +{ message => $_[0] } }
317sub optimize_as (&) { +{ optimized => $_[0] } }
a15dff8d 318
2c0cbef7 319sub enum ($;@) {
fcec2383 320 my ($type_name, @values) = @_;
4ab662d6 321 # NOTE:
322 # if only an array-ref is passed then
9f4334a1 323 # you get an anon-enum
324 # - SL
325 if (ref $type_name eq 'ARRAY' && !@values) {
326 @values = @$type_name;
327 $type_name = undef;
328 }
2c0cbef7 329 (scalar @values >= 2)
330 || confess "You must have at least two values to enumerate through";
c4fe165f 331 my %valid = map { $_ => 1 } @values;
dabed765 332
333 register_type_constraint(
334 create_enum_type_constraint(
335 $type_name,
336 \@values,
337 )
338 );
339}
340
341sub create_enum_type_constraint ($$) {
342 my ( $type_name, $values ) = @_;
e606ae5f 343
dabed765 344 Moose::Meta::TypeConstraint::Enum->new(
345 name => $type_name || '__ANON__',
346 values => $values,
a0f8153d 347 );
fcec2383 348}
349
d9b40005 350## --------------------------------------------------------
351## desugaring functions ...
352## --------------------------------------------------------
353
e85d2a5d 354sub _create_type_constraint ($$$;$$) {
d9b40005 355 my $name = shift;
356 my $parent = shift;
8de73ff1 357 my $check = shift;
e85d2a5d 358
d9b40005 359 my ($message, $optimized);
360 for (@_) {
361 $message = $_->{message} if exists $_->{message};
e85d2a5d 362 $optimized = $_->{optimized} if exists $_->{optimized};
d9b40005 363 }
364
365 my $pkg_defined_in = scalar(caller(0));
e85d2a5d 366
d9b40005 367 if (defined $name) {
368 my $type = $REGISTRY->get_type_constraint($name);
e85d2a5d 369
d9b40005 370 ($type->_package_defined_in eq $pkg_defined_in)
e85d2a5d 371 || confess ("The type constraint '$name' has already been created in "
d9b40005 372 . $type->_package_defined_in . " and cannot be created again in "
373 . $pkg_defined_in)
e85d2a5d 374 if defined $type;
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)
420 || confess "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
f1917f58 451 my $type = qr{ $valid_chars+ (?: \[ (??{$any}) \] )? }x;
452 my $type_capture_parts = qr{ ($valid_chars+) (?: \[ ((??{$any})) \] )? }x;
453 my $type_with_parameter = qr{ $valid_chars+ \[ (??{$any}) \] }x;
454
3796382a 455 my $op_union = qr{ \s* \| \s* }x;
f1917f58 456 my $union = qr{ $type (?: $op_union $type )+ }x;
457
be722745 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
e85d2a5d 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))
479 || confess "'$given' didn't parse (parse-pos="
480 . pos($given)
481 . " and str-length="
482 . length($given)
483 . ")";
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'))
631 || confess "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type";
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
745 ArrayRef[Int] # an array of intergers
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
923=item B<create_type_constraint_union ($pipe_seperated_types | @type_constraint_names)>
924
925Given string with C<$pipe_seperated_types> or a list of C<@type_constraint_names>,
926this will return a L<Moose::Meta::TypeConstraint::Union> instance.
927
928=item B<create_parameterized_type_constraint ($type_name)>
929
930Given a C<$type_name> in the form of:
931
932 BaseType[ContainerType]
933
934this will extract the base type and container type and build an instance of
935L<Moose::Meta::TypeConstraint::Parameterized> for it.
936
620db045 937=item B<create_class_type_constraint ($class, ?$options)>
004222dc 938
939Given a class name it will create a new L<Moose::Meta::TypeConstraint::Class>
940object for that class name.
941
620db045 942=item B<create_role_type_constraint ($role, ?$options)>
943
944Given a role name it will create a new L<Moose::Meta::TypeConstraint::Role>
945object for that role name.
946
dabed765 947=item B<create_enum_type_constraint ($name, $values)>
948
620db045 949=item B<find_or_parse_type_constraint ($type_name)>
004222dc 950
951This will attempt to find or create a type constraint given the a C<$type_name>.
952If it cannot find it in the registry, it will see if it should be a union or
620db045 953container type an create one if appropriate
954
955=item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
956
957This function will first call C<find_or_parse_type_constraint> with the type name.
958
959If no type is found or created, but C<$options_for_anon_type> are provided, it
960will create the corresponding type.
961
962This was used by the C<does> and C<isa> parameters to L<Moose::Meta::Attribute>
963and are now superseded by C<find_or_create_isa_type_constraint> and
964C<find_or_create_does_type_constraint>.
965
966=item B<find_or_create_isa_type_constraint ($type_name)>
967
968=item B<find_or_create_does_type_constraint ($type_name)>
969
970Attempts to parse the type name using L<find_or_parse_type_constraint> and if
971no appropriate constraint is found will create a new anonymous one.
972
973The C<isa> variant will use C<create_class_type_constraint> and the C<does>
974variant will use C<create_role_type_constraint>.
004222dc 975
976=item B<find_type_constraint ($type_name)>
977
978This function can be used to locate a specific type constraint
979meta-object, of the class L<Moose::Meta::TypeConstraint> or a
980derivative. What you do with it from there is up to you :)
981
982=item B<register_type_constraint ($type_object)>
983
984This function will register a named type constraint with the type registry.
985
986=item B<get_type_constraint_registry>
987
988Fetch the L<Moose::Meta::TypeConstraint::Registry> object which
989keeps track of all type constraints.
990
991=item B<list_all_type_constraints>
992
993This will return a list of type constraint names, you can then
994fetch them using C<find_type_constraint ($type_name)> if you
995want to.
996
997=item B<list_all_builtin_type_constraints>
998
999This will return a list of builtin type constraints, meaning,
1000those which are defined in this module. See the section
1001labeled L<Default Type Constraints> for a complete list.
1002
1003=item B<export_type_constraints_as_functions>
1004
1005This will export all the current type constraints as functions
1006into the caller's namespace. Right now, this is mostly used for
1007testing, but it might prove useful to others.
1008
1009=item B<get_all_parameterizable_types>
1010
1011This returns all the parameterizable types that have been registered.
1012
1013=item B<add_parameterizable_type ($type)>
1014
1015Adds C<$type> to the list of parameterizable types
1016
1017=back
1018
998a8a25 1019=head1 Error Management
1020
1021=over 4
1022
1023=item B<confess>
1024
1025If the caller is a Moose metaclass, use its L<Moose::Meta::Class/throw_error>
1026routine, otherwise use L<Carp/confess>.
1027
1028=back
1029
571dd39f 1030=head2 Namespace Management
1031
1032=over 4
1033
1034=item B<unimport>
1035
e85d2a5d 1036This will remove all the type constraint keywords from the
571dd39f 1037calling class namespace.
1038
1039=back
1040
a15dff8d 1041=head1 BUGS
1042
e85d2a5d 1043All complex software has bugs lurking in it, and this module is no
a15dff8d 1044exception. If you find a bug please either email me, or add the bug
1045to cpan-RT.
1046
a15dff8d 1047=head1 AUTHOR
1048
1049Stevan Little E<lt>stevan@iinteractive.comE<gt>
1050
1051=head1 COPYRIGHT AND LICENSE
1052
778db3ac 1053Copyright 2006-2008 by Infinity Interactive, Inc.
a15dff8d 1054
1055L<http://www.iinteractive.com>
1056
1057This library is free software; you can redistribute it and/or modify
e85d2a5d 1058it under the same terms as Perl itself.
a15dff8d 1059
81dc201f 1060=cut