This change gets Recipe 11 working. Here are the details ...
[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';
571dd39f 9use Sub::Exporter;
a15dff8d 10
eaa35e6e 11our $VERSION = '0.50';
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
21f1e231 293 unshift @_ => undef if scalar @_ <= 2 && ('CODE' eq ref($_[1]));
a0f8153d 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
36dbd105 386 my $class = "Moose::Meta::TypeConstraint";
4ab662d6 387
36dbd105 388 # FIXME should probably not be a special case
36dbd105 389 if ( defined $parent and $parent = find_or_parse_type_constraint($parent) ) {
a84a89ba 390 $class = "Moose::Meta::TypeConstraint::Parameterizable"
391 if $parent->isa("Moose::Meta::TypeConstraint::Parameterizable");
36dbd105 392 }
393
394 my $constraint = $class->new(
d9b40005 395 name => $name || '__ANON__',
d9b40005 396 package_defined_in => $pkg_defined_in,
e85d2a5d 397
398 ($parent ? (parent => $parent ) : ()),
399 ($check ? (constraint => $check) : ()),
400 ($message ? (message => $message) : ()),
401 ($optimized ? (optimized => $optimized) : ()),
d9b40005 402 );
4ab662d6 403
8de73ff1 404 # NOTE:
4ab662d6 405 # if we have a type constraint union, and no
8de73ff1 406 # type check, this means we are just aliasing
4ab662d6 407 # the union constraint, which means we need to
8de73ff1 408 # handle this differently.
409 # - SL
4ab662d6 410 if (not(defined $check)
411 && $parent->isa('Moose::Meta::TypeConstraint::Union')
412 && $parent->has_coercion
8de73ff1 413 ){
414 $constraint->coercion(Moose::Meta::TypeCoercion::Union->new(
415 type_constraint => $parent
416 ));
4ab662d6 417 }
d9b40005 418
419 $REGISTRY->add_type_constraint($constraint)
420 if defined $name;
421
422 return $constraint;
423}
424
e85d2a5d 425sub _install_type_coercions ($$) {
d9b40005 426 my ($type_name, $coercion_map) = @_;
427 my $type = $REGISTRY->get_type_constraint($type_name);
6f9ff1af 428 (defined $type)
429 || confess "Cannot find type '$type_name', perhaps you forgot to load it.";
41e007e4 430 if ($type->has_coercion) {
431 $type->coercion->add_type_coercions(@$coercion_map);
432 }
433 else {
434 my $type_coercion = Moose::Meta::TypeCoercion->new(
435 type_coercion_map => $coercion_map,
436 type_constraint => $type
437 );
438 $type->coercion($type_coercion);
439 }
d9b40005 440}
441
442## --------------------------------------------------------
f1917f58 443## type notation parsing ...
444## --------------------------------------------------------
445
446{
e85d2a5d 447 # All I have to say is mugwump++ cause I know
448 # do not even have enough regexp-fu to be able
449 # to have written this (I can only barely
f1917f58 450 # understand it as it is)
e85d2a5d 451 # - SL
452
f1917f58 453 use re "eval";
454
3796382a 455 my $valid_chars = qr{[\w:]};
f1917f58 456 my $type_atom = qr{ $valid_chars+ };
457
be722745 458 my $any;
459
f1917f58 460 my $type = qr{ $valid_chars+ (?: \[ (??{$any}) \] )? }x;
461 my $type_capture_parts = qr{ ($valid_chars+) (?: \[ ((??{$any})) \] )? }x;
462 my $type_with_parameter = qr{ $valid_chars+ \[ (??{$any}) \] }x;
463
3796382a 464 my $op_union = qr{ \s* \| \s* }x;
f1917f58 465 my $union = qr{ $type (?: $op_union $type )+ }x;
466
be722745 467 $any = qr{ $type | $union }x;
f1917f58 468
0fbd4b0a 469 sub _parse_parameterized_type_constraint {
be722745 470 { no warnings 'void'; $any; } # force capture of interpolated lexical
e85d2a5d 471 $_[0] =~ m{ $type_capture_parts }x;
472 return ($1, $2);
f1917f58 473 }
474
0fbd4b0a 475 sub _detect_parameterized_type_constraint {
be722745 476 { no warnings 'void'; $any; } # force capture of interpolated lexical
e85d2a5d 477 $_[0] =~ m{ ^ $type_with_parameter $ }x;
f1917f58 478 }
479
480 sub _parse_type_constraint_union {
be722745 481 { no warnings 'void'; $any; } # force capture of interpolated lexical
e85d2a5d 482 my $given = shift;
483 my @rv;
484 while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
82a5b1a7 485 push @rv => $1;
e85d2a5d 486 }
487 (pos($given) eq length($given))
488 || confess "'$given' didn't parse (parse-pos="
489 . pos($given)
490 . " and str-length="
491 . length($given)
492 . ")";
493 @rv;
f1917f58 494 }
495
496 sub _detect_type_constraint_union {
be722745 497 { no warnings 'void'; $any; } # force capture of interpolated lexical
e85d2a5d 498 $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
f1917f58 499 }
500}
501
502## --------------------------------------------------------
d9b40005 503# define some basic built-in types
504## --------------------------------------------------------
a15dff8d 505
f65cb534 506type 'Any' => where { 1 }; # meta-type including all
e85d2a5d 507type 'Item' => where { 1 }; # base-type
a15dff8d 508
fd542f49 509subtype 'Undef' => as 'Item' => where { !defined($_) };
510subtype 'Defined' => as 'Item' => where { defined($_) };
a15dff8d 511
8ecb1fa0 512subtype 'Bool'
e85d2a5d 513 => as 'Item'
8ecb1fa0 514 => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
5a4c5493 515
e85d2a5d 516subtype 'Value'
517 => as 'Defined'
518 => where { !ref($_) }
28ffb449 519 => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Value;
e85d2a5d 520
8ecb1fa0 521subtype 'Ref'
e85d2a5d 522 => as 'Defined'
523 => where { ref($_) }
28ffb449 524 => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref;
8ecb1fa0 525
e85d2a5d 526subtype 'Str'
527 => as 'Value'
528 => where { 1 }
28ffb449 529 => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str;
8ecb1fa0 530
e85d2a5d 531subtype 'Num'
532 => as 'Value'
533 => where { Scalar::Util::looks_like_number($_) }
28ffb449 534 => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Num;
e85d2a5d 535
536subtype 'Int'
537 => as 'Num'
8ecb1fa0 538 => where { "$_" =~ /^-?[0-9]+$/ }
28ffb449 539 => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
8ecb1fa0 540
28ffb449 541subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef;
28ffb449 542subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
543subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
544subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
a15dff8d 545
0a5bd159 546# NOTE:
e85d2a5d 547# scalar filehandles are GLOB refs,
0a5bd159 548# but a GLOB ref is not always a filehandle
e85d2a5d 549subtype 'FileHandle'
550 => as 'GlobRef'
128c601e 551 => where { Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") ) }
28ffb449 552 => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
0a5bd159 553
e85d2a5d 554# NOTE:
a15dff8d 555# blessed(qr/.../) returns true,.. how odd
e85d2a5d 556subtype 'Object'
557 => as 'Ref'
8ecb1fa0 558 => where { blessed($_) && blessed($_) ne 'Regexp' }
28ffb449 559 => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
a15dff8d 560
e85d2a5d 561subtype 'Role'
562 => as 'Object'
8ecb1fa0 563 => where { $_->can('does') }
28ffb449 564 => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role;
e85d2a5d 565
0e0709ea 566my $_class_name_checker = sub {
0e0709ea 567};
568
e85d2a5d 569subtype 'ClassName'
570 => as 'Str'
e151db23 571 => where { Class::MOP::is_class_loaded($_) }
572 => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName;
02a0fb52 573
d9b40005 574## --------------------------------------------------------
7e4e1ad4 575# parameterizable types ...
576
577$REGISTRY->add_type_constraint(
578 Moose::Meta::TypeConstraint::Parameterizable->new(
579 name => 'ArrayRef',
580 package_defined_in => __PACKAGE__,
581 parent => find_type_constraint('Ref'),
582 constraint => sub { ref($_) eq 'ARRAY' },
583 optimized => \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
584 constraint_generator => sub {
585 my $type_parameter = shift;
dabed765 586 my $check = $type_parameter->_compiled_type_constraint;
7e4e1ad4 587 return sub {
588 foreach my $x (@$_) {
dabed765 589 ($check->($x)) || return
7e4e1ad4 590 } 1;
591 }
592 }
593 )
594);
595
596$REGISTRY->add_type_constraint(
597 Moose::Meta::TypeConstraint::Parameterizable->new(
598 name => 'HashRef',
599 package_defined_in => __PACKAGE__,
600 parent => find_type_constraint('Ref'),
601 constraint => sub { ref($_) eq 'HASH' },
602 optimized => \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
603 constraint_generator => sub {
4ab662d6 604 my $type_parameter = shift;
dabed765 605 my $check = $type_parameter->_compiled_type_constraint;
7e4e1ad4 606 return sub {
607 foreach my $x (values %$_) {
dabed765 608 ($check->($x)) || return
7e4e1ad4 609 } 1;
610 }
611 }
612 )
613);
614
615$REGISTRY->add_type_constraint(
616 Moose::Meta::TypeConstraint::Parameterizable->new(
617 name => 'Maybe',
618 package_defined_in => __PACKAGE__,
619 parent => find_type_constraint('Item'),
620 constraint => sub { 1 },
621 constraint_generator => sub {
4ab662d6 622 my $type_parameter = shift;
dabed765 623 my $check = $type_parameter->_compiled_type_constraint;
7e4e1ad4 624 return sub {
dabed765 625 return 1 if not(defined($_)) || $check->($_);
7e4e1ad4 626 return;
627 }
628 }
629 )
630);
631
4ab662d6 632my @PARAMETERIZABLE_TYPES = map {
633 $REGISTRY->get_type_constraint($_)
7e4e1ad4 634} qw[ArrayRef HashRef Maybe];
635
636sub get_all_parameterizable_types { @PARAMETERIZABLE_TYPES }
4ab662d6 637sub add_parameterizable_type {
7e4e1ad4 638 my $type = shift;
639 (blessed $type && $type->isa('Moose::Meta::TypeConstraint::Parameterizable'))
640 || confess "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type";
641 push @PARAMETERIZABLE_TYPES => $type;
4ab662d6 642}
7e4e1ad4 643
644## --------------------------------------------------------
d9b40005 645# end of built-in types ...
646## --------------------------------------------------------
647
943596a6 648{
649 my @BUILTINS = list_all_type_constraints();
650 sub list_all_builtin_type_constraints { @BUILTINS }
651}
652
a15dff8d 6531;
654
655__END__
656
657=pod
658
659=head1 NAME
660
e522431d 661Moose::Util::TypeConstraints - Type constraint system for Moose
a15dff8d 662
663=head1 SYNOPSIS
664
665 use Moose::Util::TypeConstraints;
666
2c0cbef7 667 type 'Num' => where { Scalar::Util::looks_like_number($_) };
e85d2a5d 668
669 subtype 'Natural'
670 => as 'Num'
a15dff8d 671 => where { $_ > 0 };
e85d2a5d 672
673 subtype 'NaturalLessThanTen'
2c0cbef7 674 => as 'Natural'
79592a54 675 => where { $_ < 10 }
676 => message { "This number ($_) is not less than ten!" };
e85d2a5d 677
678 coerce 'Num'
2c0cbef7 679 => from 'Str'
e85d2a5d 680 => via { 0+$_ };
681
2c0cbef7 682 enum 'RGBColors' => qw(red green blue);
a15dff8d 683
684=head1 DESCRIPTION
685
e85d2a5d 686This module provides Moose with the ability to create custom type
687contraints to be used in attribute definition.
e522431d 688
6ba6d68c 689=head2 Important Caveat
690
e85d2a5d 691This is B<NOT> a type system for Perl 5. These are type constraints,
692and they are not used by Moose unless you tell it to. No type
693inference is performed, expression are not typed, etc. etc. etc.
6ba6d68c 694
e85d2a5d 695This is simply a means of creating small constraint functions which
004222dc 696can be used to simplify your own type-checking code, with the added
697side benefit of making your intentions clearer through self-documentation.
6ba6d68c 698
2c0cbef7 699=head2 Slightly Less Important Caveat
700
004222dc 701It is B<always> a good idea to quote your type and subtype names.
702
e85d2a5d 703This is to prevent perl from trying to execute the call as an indirect
2c0cbef7 704object call. This issue only seems to come up when you have a subtype
e85d2a5d 705the same name as a valid class, but when the issue does arise it tends
706to be quite annoying to debug.
2c0cbef7 707
708So for instance, this:
e85d2a5d 709
2c0cbef7 710 subtype DateTime => as Object => where { $_->isa('DateTime') };
711
712will I<Just Work>, while this:
713
714 use DateTime;
715 subtype DateTime => as Object => where { $_->isa('DateTime') };
716
e85d2a5d 717will fail silently and cause many headaches. The simple way to solve
718this, as well as future proof your subtypes from classes which have
2c0cbef7 719yet to have been created yet, is to simply do this:
720
721 use DateTime;
d44714be 722 subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
2c0cbef7 723
6ba6d68c 724=head2 Default Type Constraints
e522431d 725
004222dc 726This module also provides a simple hierarchy for Perl 5 types, here is
727that hierarchy represented visually.
e522431d 728
729 Any
e85d2a5d 730 Item
5a4c5493 731 Bool
7e4e1ad4 732 Maybe[`a]
f65cb534 733 Undef
734 Defined
5a4c5493 735 Value
736 Num
737 Int
738 Str
9af1d28b 739 ClassName
5a4c5493 740 Ref
741 ScalarRef
7e4e1ad4 742 ArrayRef[`a]
743 HashRef[`a]
5a4c5493 744 CodeRef
745 RegexpRef
3f7376b0 746 GlobRef
0a5bd159 747 FileHandle
e85d2a5d 748 Object
5a4c5493 749 Role
e522431d 750
4ab662d6 751B<NOTE:> Any type followed by a type parameter C<[`a]> can be
7e4e1ad4 752parameterized, this means you can say:
753
754 ArrayRef[Int] # an array of intergers
755 HashRef[CodeRef] # a hash of str to CODE ref mappings
756 Maybe[Str] # value may be a string, may be undefined
757
4ab662d6 758B<NOTE:> The C<Undef> type constraint for the most part works
759correctly now, but edge cases may still exist, please use it
7e4e1ad4 760sparringly.
703e92fb 761
7e4e1ad4 762B<NOTE:> The C<ClassName> type constraint does a complex package
4ab662d6 763existence check. This means that your class B<must> be loaded for
764this type constraint to pass. I know this is not ideal for all,
7e4e1ad4 765but it is a saner restriction than most others.
9af1d28b 766
004222dc 767=head2 Type Constraint Naming
768
769Since the types created by this module are global, it is suggested
770that you namespace your types just as you would namespace your
771modules. So instead of creating a I<Color> type for your B<My::Graphics>
772module, you would call the type I<My::Graphics::Color> instead.
773
703e92fb 774=head2 Use with Other Constraint Modules
775
e85d2a5d 776This module should play fairly nicely with other constraint
777modules with only some slight tweaking. The C<where> clause
703e92fb 778in types is expected to be a C<CODE> reference which checks
004222dc 779it's first argument and returns a boolean. Since most constraint
e85d2a5d 780modules work in a similar way, it should be simple to adapt
703e92fb 781them to work with Moose.
782
e85d2a5d 783For instance, this is how you could use it with
784L<Declare::Constraints::Simple> to declare a completely new type.
703e92fb 785
e85d2a5d 786 type 'HashOfArrayOfObjects'
703e92fb 787 => IsHashRef(
788 -keys => HasLength,
789 -values => IsArrayRef( IsObject ));
790
004222dc 791For more examples see the F<t/200_examples/204_example_w_DCS.t>
792test file.
703e92fb 793
e85d2a5d 794Here is an example of using L<Test::Deep> and it's non-test
795related C<eq_deeply> function.
703e92fb 796
e85d2a5d 797 type 'ArrayOfHashOfBarsAndRandomNumbers'
703e92fb 798 => where {
e85d2a5d 799 eq_deeply($_,
703e92fb 800 array_each(subhashof({
801 bar => isa('Bar'),
802 random_number => ignore()
e85d2a5d 803 })))
703e92fb 804 };
805
004222dc 806For a complete example see the
807F<t/200_examples/205_example_w_TestDeep.t> test file.
e85d2a5d 808
a15dff8d 809=head1 FUNCTIONS
810
811=head2 Type Constraint Constructors
812
e85d2a5d 813The following functions are used to create type constraints.
814They will then register the type constraints in a global store
815where Moose can get to them if it needs to.
a15dff8d 816
25f2c3fc 817See the L<SYNOPSIS> for an example of how to use these.
a15dff8d 818
6ba6d68c 819=over 4
a15dff8d 820
6ba6d68c 821=item B<type ($name, $where_clause)>
a15dff8d 822
e85d2a5d 823This creates a base type, which has no parent.
a15dff8d 824
79592a54 825=item B<subtype ($name, $parent, $where_clause, ?$message)>
182134e8 826
e85d2a5d 827This creates a named subtype.
d6e2d9a1 828
79592a54 829=item B<subtype ($parent, $where_clause, ?$message)>
182134e8 830
e85d2a5d 831This creates an unnamed subtype and will return the type
832constraint meta-object, which will be an instance of
833L<Moose::Meta::TypeConstraint>.
a15dff8d 834
620db045 835=item B<class_type ($class, ?$options)>
3fef8ce8 836
837Creates a type constraint with the name C<$class> and the metaclass
838L<Moose::Meta::TypeConstraint::Class>.
839
620db045 840=item B<role_type ($role, ?$options)>
841
842Creates a type constraint with the name C<$role> and the metaclass
843L<Moose::Meta::TypeConstraint::Role>.
844
fcec2383 845=item B<enum ($name, @values)>
846
e85d2a5d 847This will create a basic subtype for a given set of strings.
848The resulting constraint will be a subtype of C<Str> and
4ce56d04 849will match any of the items in C<@values>. It is case sensitive.
850See the L<SYNOPSIS> for a simple example.
2c0cbef7 851
e85d2a5d 852B<NOTE:> This is not a true proper enum type, it is simple
2c0cbef7 853a convient constraint builder.
854
9f4334a1 855=item B<enum (\@values)>
856
4ab662d6 857If passed an ARRAY reference instead of the C<$name>, C<@values> pair,
9f4334a1 858this will create an unnamed enum. This can then be used in an attribute
859definition like so:
860
861 has 'sort_order' => (
862 is => 'ro',
4ab662d6 863 isa => enum([qw[ ascending descending ]]),
9f4334a1 864 );
865
6ba6d68c 866=item B<as>
a15dff8d 867
6ba6d68c 868This is just sugar for the type constraint construction syntax.
a15dff8d 869
6ba6d68c 870=item B<where>
a15dff8d 871
6ba6d68c 872This is just sugar for the type constraint construction syntax.
76d37e5a 873
874=item B<message>
875
876This is just sugar for the type constraint construction syntax.
a15dff8d 877
8ecb1fa0 878=item B<optimize_as>
879
e85d2a5d 880This can be used to define a "hand optimized" version of your
d44714be 881type constraint which can be used to avoid traversing a subtype
e85d2a5d 882constraint heirarchy.
d44714be 883
e85d2a5d 884B<NOTE:> You should only use this if you know what you are doing,
885all the built in types use this, so your subtypes (assuming they
d44714be 886are shallow) will not likely need to use this.
887
6ba6d68c 888=back
a15dff8d 889
6ba6d68c 890=head2 Type Coercion Constructors
a15dff8d 891
e85d2a5d 892Type constraints can also contain type coercions as well. If you
893ask your accessor to coerce, then Moose will run the type-coercion
894code first, followed by the type constraint check. This feature
895should be used carefully as it is very powerful and could easily
587ae0d2 896take off a limb if you are not careful.
a15dff8d 897
25f2c3fc 898See the L<SYNOPSIS> for an example of how to use these.
a15dff8d 899
6ba6d68c 900=over 4
a15dff8d 901
6ba6d68c 902=item B<coerce>
a15dff8d 903
6ba6d68c 904=item B<from>
a15dff8d 905
6ba6d68c 906This is just sugar for the type coercion construction syntax.
907
908=item B<via>
a15dff8d 909
6ba6d68c 910This is just sugar for the type coercion construction syntax.
a15dff8d 911
912=back
913
004222dc 914=head2 Type Constraint Construction & Locating
915
916=over 4
917
918=item B<create_type_constraint_union ($pipe_seperated_types | @type_constraint_names)>
919
920Given string with C<$pipe_seperated_types> or a list of C<@type_constraint_names>,
921this will return a L<Moose::Meta::TypeConstraint::Union> instance.
922
923=item B<create_parameterized_type_constraint ($type_name)>
924
925Given a C<$type_name> in the form of:
926
927 BaseType[ContainerType]
928
929this will extract the base type and container type and build an instance of
930L<Moose::Meta::TypeConstraint::Parameterized> for it.
931
620db045 932=item B<create_class_type_constraint ($class, ?$options)>
004222dc 933
934Given a class name it will create a new L<Moose::Meta::TypeConstraint::Class>
935object for that class name.
936
620db045 937=item B<create_role_type_constraint ($role, ?$options)>
938
939Given a role name it will create a new L<Moose::Meta::TypeConstraint::Role>
940object for that role name.
941
dabed765 942=item B<create_enum_type_constraint ($name, $values)>
943
620db045 944=item B<find_or_parse_type_constraint ($type_name)>
004222dc 945
946This will attempt to find or create a type constraint given the a C<$type_name>.
947If it cannot find it in the registry, it will see if it should be a union or
620db045 948container type an create one if appropriate
949
950=item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
951
952This function will first call C<find_or_parse_type_constraint> with the type name.
953
954If no type is found or created, but C<$options_for_anon_type> are provided, it
955will create the corresponding type.
956
957This was used by the C<does> and C<isa> parameters to L<Moose::Meta::Attribute>
958and are now superseded by C<find_or_create_isa_type_constraint> and
959C<find_or_create_does_type_constraint>.
960
961=item B<find_or_create_isa_type_constraint ($type_name)>
962
963=item B<find_or_create_does_type_constraint ($type_name)>
964
965Attempts to parse the type name using L<find_or_parse_type_constraint> and if
966no appropriate constraint is found will create a new anonymous one.
967
968The C<isa> variant will use C<create_class_type_constraint> and the C<does>
969variant will use C<create_role_type_constraint>.
004222dc 970
971=item B<find_type_constraint ($type_name)>
972
973This function can be used to locate a specific type constraint
974meta-object, of the class L<Moose::Meta::TypeConstraint> or a
975derivative. What you do with it from there is up to you :)
976
977=item B<register_type_constraint ($type_object)>
978
979This function will register a named type constraint with the type registry.
980
981=item B<get_type_constraint_registry>
982
983Fetch the L<Moose::Meta::TypeConstraint::Registry> object which
984keeps track of all type constraints.
985
986=item B<list_all_type_constraints>
987
988This will return a list of type constraint names, you can then
989fetch them using C<find_type_constraint ($type_name)> if you
990want to.
991
992=item B<list_all_builtin_type_constraints>
993
994This will return a list of builtin type constraints, meaning,
995those which are defined in this module. See the section
996labeled L<Default Type Constraints> for a complete list.
997
998=item B<export_type_constraints_as_functions>
999
1000This will export all the current type constraints as functions
1001into the caller's namespace. Right now, this is mostly used for
1002testing, but it might prove useful to others.
1003
1004=item B<get_all_parameterizable_types>
1005
1006This returns all the parameterizable types that have been registered.
1007
1008=item B<add_parameterizable_type ($type)>
1009
1010Adds C<$type> to the list of parameterizable types
1011
1012=back
1013
571dd39f 1014=head2 Namespace Management
1015
1016=over 4
1017
1018=item B<unimport>
1019
e85d2a5d 1020This will remove all the type constraint keywords from the
571dd39f 1021calling class namespace.
1022
1023=back
1024
a15dff8d 1025=head1 BUGS
1026
e85d2a5d 1027All complex software has bugs lurking in it, and this module is no
a15dff8d 1028exception. If you find a bug please either email me, or add the bug
1029to cpan-RT.
1030
a15dff8d 1031=head1 AUTHOR
1032
1033Stevan Little E<lt>stevan@iinteractive.comE<gt>
1034
1035=head1 COPYRIGHT AND LICENSE
1036
778db3ac 1037Copyright 2006-2008 by Infinity Interactive, Inc.
a15dff8d 1038
1039L<http://www.iinteractive.com>
1040
1041This library is free software; you can redistribute it and/or modify
e85d2a5d 1042it under the same terms as Perl itself.
a15dff8d 1043
81dc201f 1044=cut