1 package Mouse::Util::TypeConstraints;
8 use Scalar::Util qw/blessed looks_like_number openhandle/;
10 use Mouse::Util qw(does_role not_supported);
11 use Mouse::Meta::Module; # class_of
12 use Mouse::Meta::TypeConstraint;
14 use constant _DEBUG => !!$ENV{TC_DEBUG};
16 our @ISA = qw(Exporter);
18 as where message from via type subtype coerce class_type role_type enum
30 return(where => $_[0])
33 return(message => $_[0])
41 Any => undef, # null check
42 Item => undef, # null check
43 Maybe => undef, # null check
45 Bool => sub { $_[0] ? $_[0] eq '1' : 1 },
46 Undef => sub { !defined($_[0]) },
47 Defined => sub { defined($_[0]) },
48 Value => sub { defined($_[0]) && !ref($_[0]) },
49 Num => sub { !ref($_[0]) && looks_like_number($_[0]) },
50 Int => sub { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ },
51 Str => sub { defined($_[0]) && !ref($_[0]) },
52 Ref => sub { ref($_[0]) },
54 ScalarRef => sub { ref($_[0]) eq 'SCALAR' },
55 ArrayRef => sub { ref($_[0]) eq 'ARRAY' },
56 HashRef => sub { ref($_[0]) eq 'HASH' },
57 CodeRef => sub { ref($_[0]) eq 'CODE' },
58 RegexpRef => sub { ref($_[0]) eq 'Regexp' },
59 GlobRef => sub { ref($_[0]) eq 'GLOB' },
62 ref($_[0]) eq 'GLOB' && openhandle($_[0])
64 blessed($_[0]) && $_[0]->isa("IO::Handle")
67 Object => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' },
69 ClassName => sub { Mouse::Util::is_class_loaded($_[0]) },
70 RoleName => sub { (Mouse::Util::find_meta($_[0]) || return 0)->isa('Mouse::Meta::Role') },
73 while (my ($name, $code) = each %builtins) {
74 $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
76 _compiled_type_constraint => $code,
77 package_defined_in => __PACKAGE__,
81 sub optimized_constraints {
82 Carp::cluck('optimized_constraints() has been deprecated');
86 my @builtins = keys %TYPE;
87 sub list_all_builtin_type_constraints { @builtins }
89 sub list_all_type_constraints { keys %TYPE }
98 if(@_ == 1 && ref $_[0]){ # @_ : { name => $name, where => ... }
101 elsif(@_ == 2 && ref $_[1]){ # @_ : $name => { where => ... }
105 elsif(@_ % 2){ # @_ : $name => ( where => ... )
108 else{ # @_ : (name => $name, where => ...)
113 if(!defined($name = $args{name})){
120 my $package_defined_in = $args{package_defined_in} ||= caller(1);
122 my $existing = $TYPE{$name};
123 if($existing && $existing->{package_defined_in} ne $package_defined_in){
124 confess("The type constraint '$name' has already been created in "
125 . "$existing->{package_defined_in} and cannot be created again in $package_defined_in");
128 $args{constraint} = delete($args{where})
129 if exists $args{where};
130 $args{_compiled_type_constraint} = delete $args{optimized_as}
131 if exists $args{optimized_as};
134 if($mode eq 'subtype'){
135 my $parent = exists($args{as}) ? delete($args{as}) : delete($args{name});
137 $parent = blessed($parent) ? $parent : find_or_create_isa_type_constraint($parent);
138 $constraint = $parent->create_child_type(%args);
141 $constraint = Mouse::Meta::TypeConstraint->new(%args);
144 return $TYPE{$name} = $constraint;
148 return _create_type('type', @_);
152 return _create_type('subtype', @_);
159 confess "Cannot find type '$name', perhaps you forgot to load it."
162 unless ($COERCE{$name}) {
164 $COERCE_KEYS{$name} = [];
167 my $package_defined_in = caller;
169 while (my($from, $code) = splice @_, 0, 2) {
172 confess "A coercion action already exists for '$from'"
173 if $COERCE{$name}->{$from};
175 my $type = find_or_parse_type_constraint($from, $package_defined_in);
177 confess "Could not find the type constraint ($from) to coerce from"
180 warn "# REGISTER COERCE $name, from $type\n" if _DEBUG;
182 push @{ $COERCE_KEYS{$name} }, $type;
183 $COERCE{$name}->{$from} = $code;
189 my($name, $conf) = @_;
190 if ($conf && $conf->{class}) {
191 # No, you're using this wrong
192 warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?";
193 _create_type 'type', $name => (
194 as => $conf->{class},
200 _create_type 'type', $name => (
201 optimized_as => sub { blessed($_[0]) && $_[0]->isa($name) },
209 my($name, $conf) = @_;
210 my $role = ($conf && $conf->{role}) ? $conf->{role} : $name;
211 _create_type 'type', $name => (
212 optimized_as => sub { blessed($_[0]) && does_role($_[0], $role) },
218 # this is an original method for Mouse
219 sub typecast_constraints {
220 my($class, $pkg, $types, $value) = @_;
221 Carp::croak("wrong arguments count") unless @_ == 4;
224 for my $type ($types, ($types->{type_constraints} ? @{$types->{type_constraints}} : ()) ) {
225 for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
228 warn sprintf "# COERCE: from %s to %s for %s (%s)\n",
229 $coerce_type, $type, defined($value) ? $value : 'undef',
230 $coerce_type->check($value) ? "try" : "skip";
233 next if !$coerce_type->check($value);
237 $_ = $COERCE{$type}->{$coerce_type}->($_); # coerce
240 warn sprintf "# COERCE: got %s, which is%s %s\n",
241 defined($_) ? $_ : 'undef', $types->check($_) ? '' : ' not', $types;
244 return $_ if $types->check($_); # check for $types, not $constraint
253 # enum ['small', 'medium', 'large']
254 if (ref($_[0]) eq 'ARRAY') {
255 %valid = map{ $_ => undef } @{ $_[0] };
256 $name = sprintf '(%s)', join '|', sort @{$_[0]};
258 # enum size => 'small', 'medium', 'large'
261 %valid = map{ $_ => undef } @_;
263 return _create_type 'type', $name => (
264 optimized_as => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} },
270 sub _find_or_create_regular_type{
273 return $TYPE{$spec} if exists $TYPE{$spec};
275 my $meta = Mouse::Meta::Module::class_of($spec);
283 if($meta && $meta->isa('Mouse::Meta::Role')){
285 return blessed($_[0]) && $_[0]->does($spec);
291 return blessed($_[0]) && $_[0]->isa($spec);
296 warn "#CREATE a $type type for $spec\n" if _DEBUG;
298 return $TYPE{$spec} = Mouse::Meta::TypeConstraint->new(
300 _compiled_type_constraint => $check,
306 $TYPE{ArrayRef}{constraint_generator} = sub {
307 my($type_parameter) = @_;
308 my $check = $type_parameter->{_compiled_type_constraint};
311 foreach my $value (@{$_}) {
312 return undef unless $check->($value);
317 $TYPE{HashRef}{constraint_generator} = sub {
318 my($type_parameter) = @_;
319 my $check = $type_parameter->{_compiled_type_constraint};
322 foreach my $value(values %{$_}){
323 return undef unless $check->($value);
329 # 'Maybe' type accepts 'Any', so it requires parameters
330 $TYPE{Maybe}{constraint_generator} = sub {
331 my($type_parameter) = @_;
332 my $check = $type_parameter->{_compiled_type_constraint};
335 return !defined($_) || $check->($_);
339 sub _find_or_create_parameterized_type{
340 my($base, $param) = @_;
342 my $name = sprintf '%s[%s]', $base->name, $param->name;
345 warn "#CREATE a Parameterized type for $name\n" if _DEBUG;
347 my $generator = $base->{constraint_generator};
350 confess("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
353 Mouse::Meta::TypeConstraint->new(
356 constraint => $generator->($param),
358 type => 'Parameterized',
362 sub _find_or_create_union_type{
363 my @types = map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
365 my $name = join '|', map{ $_->name } @types;
368 warn "# CREATE a Union type for ", Mouse::Util::english_list(@types),"\n" if _DEBUG;
371 foreach my $type(@types){
372 return 1 if $type->check($_[0]);
377 return Mouse::Meta::TypeConstraint->new(
379 _compiled_type_constraint => $check,
380 type_constraints => \@types,
389 my($spec, $start) = @_;
394 my $len = length $spec;
397 for($i = $start; $i < $len; $i++){
398 my $char = substr($spec, $i, 1);
401 my $base = _find_or_create_regular_type( substr($spec, $start, $i - $start))
404 ($i, $subtype) = _parse_type($spec, $i+1)
406 $start = $i+1; # reset
408 push @list, _find_or_create_parameterized_type($base => $subtype);
415 my $type = _find_or_create_regular_type( substr($spec, $start, $i - $start))
420 ($i, $subtype) = _parse_type($spec, $i+1)
423 $start = $i+1; # reset
425 push @list, $subtype;
429 push @list, _find_or_create_regular_type(substr $spec, $start, $i - $start);
436 return ($len, $list[0]);
439 return ($len, _find_or_create_union_type(@list));
444 sub find_type_constraint {
446 return $spec if blessed($spec);
452 sub find_or_parse_type_constraint {
455 return $spec if blessed($spec);
458 return $TYPE{$spec} || do{
459 my($pos, $type) = _parse_type($spec, 0);
464 sub find_or_create_does_type_constraint{
465 my $type = find_or_parse_type_constriant(@_) || role_type(@_);
467 if($type->{type} && $type->{type} ne 'Role'){
468 Carp::cluck("$type is not a role type");
473 sub find_or_create_isa_type_constraint {
474 return find_or_parse_type_constraint(@_) || class_type(@_);
483 Mouse::Util::TypeConstraints - Type constraint system for Mouse
487 use Mouse::Util::TypeConstraints;
493 subtype 'NaturalLessThanTen'
496 => message { "This number ($_) is not less than ten!" };
502 enum 'RGBColors' => qw(red green blue);
504 no Mouse::Util::TypeConstraints;
508 This module provides Mouse with the ability to create custom type
509 constraints to be used in attribute definition.
511 =head2 Important Caveat
513 This is B<NOT> a type system for Perl 5. These are type constraints,
514 and they are not used by Mouse unless you tell it to. No type
515 inference is performed, expressions are not typed, etc. etc. etc.
517 A type constraint is at heart a small "check if a value is valid"
518 function. A constraint can be associated with an attribute. This
519 simplifies parameter validation, and makes your code clearer to read,
520 because you can refer to constraints by name.
522 =head2 Slightly Less Important Caveat
524 It is B<always> a good idea to quote your type names.
526 This prevents Perl from trying to execute the call as an indirect
527 object call. This can be an issue when you have a subtype with the
528 same name as a valid class.
532 subtype DateTime => as Object => where { $_->isa('DateTime') };
534 will I<just work>, while this:
537 subtype DateTime => as Object => where { $_->isa('DateTime') };
539 will fail silently and cause many headaches. The simple way to solve
540 this, as well as future proof your subtypes from classes which have
541 yet to have been created, is to quote the type name:
544 subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
546 =head2 Default Type Constraints
548 This module also provides a simple hierarchy for Perl 5 types, here is
549 that hierarchy represented visually.
573 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
574 parameterized, this means you can say:
576 ArrayRef[Int] # an array of integers
577 HashRef[CodeRef] # a hash of str to CODE ref mappings
578 Maybe[Str] # value may be a string, may be undefined
580 If Mouse finds a name in brackets that it does not recognize as an
581 existing type, it assumes that this is a class name, for example
582 C<ArrayRef[DateTime]>.
584 B<NOTE:> Unless you parameterize a type, then it is invalid to include
585 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
586 name, I<not> as a parameterization of C<ArrayRef>.
588 B<NOTE:> The C<Undef> type constraint for the most part works
589 correctly now, but edge cases may still exist, please use it
592 B<NOTE:> The C<ClassName> type constraint does a complex package
593 existence check. This means that your class B<must> be loaded for this
594 type constraint to pass.
596 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
597 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
598 constraint checks that an I<object does> the named role.
600 =head2 Type Constraint Naming
602 Type name declared via this module can only contain alphanumeric
603 characters, colons (:), and periods (.).
605 Since the types created by this module are global, it is suggested
606 that you namespace your types just as you would namespace your
607 modules. So instead of creating a I<Color> type for your
608 B<My::Graphics> module, you would call the type
609 I<My::Graphics::Types::Color> instead.
611 =head2 Use with Other Constraint Modules
613 This module can play nicely with other constraint modules with some
614 slight tweaking. The C<where> clause in types is expected to be a
615 C<CODE> reference which checks it's first argument and returns a
616 boolean. Since most constraint modules work in a similar way, it
617 should be simple to adapt them to work with Mouse.
619 For instance, this is how you could use it with
620 L<Declare::Constraints::Simple> to declare a completely new type.
622 type 'HashOfArrayOfObjects',
626 -values => IsArrayRef(IsObject)
630 Here is an example of using L<Test::Deep> and it's non-test
631 related C<eq_deeply> function.
633 type 'ArrayOfHashOfBarsAndRandomNumbers'
636 array_each(subhashof({
638 random_number => ignore()
644 =head2 optimized_constraints -> HashRef[CODE]
646 Returns the simple type constraints that Mouse understands.
652 =item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >>
654 =item C<< subtype as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >>
656 =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >>
658 =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
660 =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
666 =item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >>
672 Much of this documentation was taken from C<Moose::Util::TypeConstraints>
676 L<Moose::Util::TypeConstraints>