lib/Mouse/Util/TypeConstraints.pm

   1 package Mouse::Util::TypeConstraints;
   2 use Mouse::Util qw(does_role not_supported); # enables strict and warnings
   3
   4 use Carp qw(confess);
   5 use Scalar::Util ();
   6
   7 use Mouse::Meta::TypeConstraint;
   8 use Mouse::Exporter;
   9
  10 Mouse::Exporter->setup_import_methods(
  11     as_is => [qw(
  12         as where message optimize_as
  13         from via
  14         type subtype coerce class_type role_type enum
  15         find_type_constraint
  16     )],
  17 );
  18
  19 my %TYPE;
  20
  21 sub as          ($) { (as          => $_[0]) }
  22 sub where       (&) { (where       => $_[0]) }
  23 sub message     (&) { (message     => $_[0]) }
  24 sub optimize_as (&) { (optimize_as => $_[0]) }
  25
  26 sub from    { @_ }
  27 sub via (&) { $_[0] }
  28
  29 BEGIN {
  30     my %builtins = (
  31         Any        => undef, # null check
  32         Item       => undef, # null check
  33         Maybe      => undef, # null check
  34
  35         Bool       => \&Bool,
  36         Undef      => \&Undef,
  37         Defined    => \&Defined,
  38         Value      => \&Value,
  39         Num        => \&Num,
  40         Int        => \&Int,
  41         Str        => \&Str,
  42         Ref        => \&Ref,
  43
  44         ScalarRef  => \&ScalarRef,
  45         ArrayRef   => \&ArrayRef,
  46         HashRef    => \&HashRef,
  47         CodeRef    => \&CodeRef,
  48         RegexpRef  => \&RegexpRef,
  49         GlobRef    => \&GlobRef,
  50
  51         FileHandle => \&FileHandle,
  52
  53         Object     => \&Object,
  54
  55         ClassName  => \&ClassName,
  56         RoleName   => \&RoleName,
  57     );
  58
  59     while (my ($name, $code) = each %builtins) {
  60         $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
  61             name      => $name,
  62             optimized => $code,
  63         );
  64     }
  65
  66     sub optimized_constraints { # DEPRECATED
  67         Carp::cluck('optimized_constraints() has been deprecated');
  68         return \%TYPE;
  69     }
  70
  71     my @builtins = keys %TYPE;
  72     sub list_all_builtin_type_constraints { @builtins }
  73
  74     sub list_all_type_constraints         { keys %TYPE }
  75 }
  76
  77 sub _create_type{
  78     my $mode = shift;
  79
  80     my $name;
  81     my %args;
  82
  83     if(@_ == 1 && ref $_[0]){   # @_ : { name => $name, where => ... }
  84         %args = %{$_[0]};
  85     }
  86     elsif(@_ == 2 && ref $_[1]){ # @_ : $name => { where => ... }
  87         $name = $_[0];
  88         %args = %{$_[1]};
  89     }
  90     elsif(@_ % 2){               # @_ : $name => ( where => ... )
  91         ($name, %args) = @_;
  92     }
  93     else{                        # @_ : (name => $name, where => ...)
  94         %args = @_;
  95     }
  96
  97     if(!defined $name){
  98         if(!defined($name = $args{name})){
  99             $name = '__ANON__';
 100         }
 101     }
 102
 103     $args{name} = $name;
 104     my $parent;
 105     if($mode eq 'subtype'){
 106         $parent = delete $args{as};
 107         if(!$parent){
 108             $parent = delete $args{name};
 109             $name   = '__ANON__';
 110         }
 111     }
 112
 113     my $package_defined_in = $args{package_defined_in} ||= caller(1);
 114
 115     my $existing = $TYPE{$name};
 116     if($existing && $existing->{package_defined_in} ne $package_defined_in){
 117         confess("The type constraint '$name' has already been created in "
 118               . "$existing->{package_defined_in} and cannot be created again in $package_defined_in");
 119     }
 120
 121     $args{constraint} = delete $args{where}        if exists $args{where};
 122     $args{optimized}  = delete $args{optimized_as} if exists $args{optimized_as};
 123
 124     my $constraint;
 125     if($mode eq 'subtype'){
 126         $constraint = find_or_create_isa_type_constraint($parent)->create_child_type(%args);
 127     }
 128     else{
 129         $constraint = Mouse::Meta::TypeConstraint->new(%args);
 130     }
 131
 132     return $TYPE{$name} = $constraint;
 133 }
 134
 135 sub type {
 136     return _create_type('type', @_);
 137 }
 138
 139 sub subtype {
 140     return _create_type('subtype', @_);
 141 }
 142
 143 sub coerce {
 144     my $type_name = shift;
 145
 146     my $type = find_type_constraint($type_name)
 147         or confess("Cannot find type '$type_name', perhaps you forgot to load it.");
 148
 149     $type->_add_type_coercions(@_);
 150     return;
 151 }
 152
 153 sub class_type {
 154     my($name, $options) = @_;
 155     my $class = $options->{class} || $name;
 156     return _create_type 'subtype', $name => (
 157         as           => 'Object',
 158         optimized_as => Mouse::Util::_generate_isa_predicate_for($class),
 159
 160         type => 'Class',
 161     );
 162 }
 163
 164 sub role_type {
 165     my($name, $options) = @_;
 166     my $role = $options->{role} || $name;
 167     return _create_type 'subtype', $name => (
 168         as           => 'Object',
 169         optimized_as => sub { Scalar::Util::blessed($_[0]) && does_role($_[0], $role) },
 170
 171         type => 'Role',
 172     );
 173 }
 174
 175 sub typecast_constraints { # DEPRECATED
 176     my($class, $pkg, $type, $value) = @_;
 177     Carp::croak("wrong arguments count") unless @_ == 4;
 178
 179     Carp::cluck("typecast_constraints() has been deprecated, which was an internal utility anyway");
 180
 181     return $type->coerce($value);
 182 }
 183
 184 sub enum {
 185     my($name, %valid);
 186
 187     # enum ['small', 'medium', 'large']
 188     if (ref($_[0]) eq 'ARRAY') {
 189         %valid = map{ $_ => undef } @{ $_[0] };
 190         $name  = sprintf '(%s)', join '|', sort @{$_[0]};
 191     }
 192     # enum size => 'small', 'medium', 'large'
 193     else{
 194         $name  = shift;
 195         %valid = map{ $_ => undef } @_;
 196     }
 197     return _create_type 'type', $name => (
 198         optimized_as  => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} },
 199
 200         type => 'Enum',
 201     );
 202 }
 203
 204 sub _find_or_create_regular_type{
 205     my($spec)  = @_;
 206
 207     return $TYPE{$spec} if exists $TYPE{$spec};
 208
 209     my $meta = Mouse::Util::get_metaclass_by_name($spec)
 210         or return undef;
 211
 212     if(Mouse::Util::is_a_metarole($meta)){
 213         return role_type($spec);
 214     }
 215     else{
 216         return class_type($spec);
 217     }
 218 }
 219
 220 $TYPE{ArrayRef}{constraint_generator} = sub {
 221     my($type_parameter) = @_;
 222     my $check = $type_parameter->_compiled_type_constraint;
 223
 224     return sub{
 225         foreach my $value (@{$_}) {
 226             return undef unless $check->($value);
 227         }
 228         return 1;
 229     }
 230 };
 231 $TYPE{HashRef}{constraint_generator} = sub {
 232     my($type_parameter) = @_;
 233     my $check = $type_parameter->_compiled_type_constraint;
 234
 235     return sub{
 236         foreach my $value(values %{$_}){
 237             return undef unless $check->($value);
 238         }
 239         return 1;
 240     };
 241 };
 242
 243 # 'Maybe' type accepts 'Any', so it requires parameters
 244 $TYPE{Maybe}{constraint_generator} = sub {
 245     my($type_parameter) = @_;
 246     my $check = $type_parameter->_compiled_type_constraint;
 247
 248     return sub{
 249         return !defined($_) || $check->($_);
 250     };
 251 };
 252
 253 sub _find_or_create_parameterized_type{
 254     my($base, $param) = @_;
 255
 256     my $name = sprintf '%s[%s]', $base->name, $param->name;
 257
 258     $TYPE{$name} ||= $base->parameterize($param, $name);
 259 }
 260
 261 sub _find_or_create_union_type{
 262     my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
 263
 264     my $name = join '|', @types;
 265
 266     $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new(
 267         name              => $name,
 268         type_constraints  => \@types,
 269
 270         type              => 'Union',
 271     );
 272 }
 273
 274 # The type parser
 275 sub _parse_type{
 276     my($spec, $start) = @_;
 277
 278     my @list;
 279     my $subtype;
 280
 281     my $len = length $spec;
 282     my $i;
 283
 284     for($i = $start; $i < $len; $i++){
 285         my $char = substr($spec, $i, 1);
 286
 287         if($char eq '['){
 288             my $base = _find_or_create_regular_type( substr($spec, $start, $i - $start) )
 289                 or return;
 290
 291             ($i, $subtype) = _parse_type($spec, $i+1)
 292                 or return;
 293             $start = $i+1; # reset
 294
 295             push @list, _find_or_create_parameterized_type($base => $subtype);
 296         }
 297         elsif($char eq ']'){
 298             $len = $i+1;
 299             last;
 300         }
 301         elsif($char eq '|'){
 302             my $type = _find_or_create_regular_type( substr($spec, $start, $i - $start) );
 303
 304             if(!defined $type){
 305                 # XXX: Mouse creates a new class type, but Moose does not.
 306                 $type = class_type( substr($spec, $start, $i - $start) );
 307             }
 308
 309             push @list, $type;
 310
 311             ($i, $subtype) = _parse_type($spec, $i+1)
 312                 or return;
 313
 314             $start = $i+1; # reset
 315
 316             push @list, $subtype;
 317         }
 318     }
 319     if($i - $start){
 320         my $type = _find_or_create_regular_type( substr $spec, $start, $i - $start );
 321
 322         if(defined $type){
 323             push @list, $type;
 324         }
 325         elsif($start != 0) {
 326             # RT #50421
 327             # create a new class type
 328             push @list, class_type( substr $spec, $start, $i - $start );
 329         }
 330     }
 331
 332     if(@list == 0){
 333        return;
 334     }
 335     elsif(@list == 1){
 336         return ($len, $list[0]);
 337     }
 338     else{
 339         return ($len, _find_or_create_union_type(@list));
 340     }
 341 }
 342
 343
 344 sub find_type_constraint {
 345     my($spec) = @_;
 346     return $spec if Mouse::Util::is_a_type_constraint($spec);
 347
 348     $spec =~ s/\s+//g;
 349     return $TYPE{$spec};
 350 }
 351
 352 sub find_or_parse_type_constraint {
 353     my($spec) = @_;
 354     return $spec if Mouse::Util::is_a_type_constraint($spec);
 355
 356     $spec =~ s/\s+//g;
 357     return $TYPE{$spec} || do{
 358         my($pos, $type) = _parse_type($spec, 0);
 359         $type;
 360     };
 361 }
 362
 363 sub find_or_create_does_type_constraint{
 364     # XXX: Moose does not register a new role_type, but Mouse does.
 365     return find_or_parse_type_constraint(@_) || role_type(@_);
 366 }
 367
 368 sub find_or_create_isa_type_constraint {
 369     # XXX: Moose does not register a new class_type, but Mouse does.
 370     return find_or_parse_type_constraint(@_) || class_type(@_);
 371 }
 372
 373 1;
 374
 375 __END__
 376
 377 =head1 NAME
 378
 379 Mouse::Util::TypeConstraints - Type constraint system for Mouse
 380
 381 =head1 VERSION
 382
 383 This document describes Mouse version 0.40_03
 384
 385 =head2 SYNOPSIS
 386
 387   use Mouse::Util::TypeConstraints;
 388
 389   subtype 'Natural'
 390       => as 'Int'
 391       => where { $_ > 0 };
 392
 393   subtype 'NaturalLessThanTen'
 394       => as 'Natural'
 395       => where { $_ < 10 }
 396       => message { "This number ($_) is not less than ten!" };
 397
 398   coerce 'Num'
 399       => from 'Str'
 400         => via { 0+$_ };
 401
 402   enum 'RGBColors' => qw(red green blue);
 403
 404   no Mouse::Util::TypeConstraints;
 405
 406 =head1 DESCRIPTION
 407
 408 This module provides Mouse with the ability to create custom type
 409 constraints to be used in attribute definition.
 410
 411 =head2 Important Caveat
 412
 413 This is B<NOT> a type system for Perl 5. These are type constraints,
 414 and they are not used by Mouse unless you tell it to. No type
 415 inference is performed, expressions are not typed, etc. etc. etc.
 416
 417 A type constraint is at heart a small "check if a value is valid"
 418 function. A constraint can be associated with an attribute. This
 419 simplifies parameter validation, and makes your code clearer to read,
 420 because you can refer to constraints by name.
 421
 422 =head2 Slightly Less Important Caveat
 423
 424 It is B<always> a good idea to quote your type names.
 425
 426 This prevents Perl from trying to execute the call as an indirect
 427 object call. This can be an issue when you have a subtype with the
 428 same name as a valid class.
 429
 430 For instance:
 431
 432   subtype DateTime => as Object => where { $_->isa('DateTime') };
 433
 434 will I<just work>, while this:
 435
 436   use DateTime;
 437   subtype DateTime => as Object => where { $_->isa('DateTime') };
 438
 439 will fail silently and cause many headaches. The simple way to solve
 440 this, as well as future proof your subtypes from classes which have
 441 yet to have been created, is to quote the type name:
 442
 443   use DateTime;
 444   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 445
 446 =head2 Default Type Constraints
 447
 448 This module also provides a simple hierarchy for Perl 5 types, here is
 449 that hierarchy represented visually.
 450
 451   Any
 452   Item
 453       Bool
 454       Maybe[`a]
 455       Undef
 456       Defined
 457           Value
 458               Num
 459                 Int
 460               Str
 461                 ClassName
 462                 RoleName
 463           Ref
 464               ScalarRef
 465               ArrayRef[`a]
 466               HashRef[`a]
 467               CodeRef
 468               RegexpRef
 469               GlobRef
 470                 FileHandle
 471               Object
 472
 473 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 474 parameterized, this means you can say:
 475
 476   ArrayRef[Int]    # an array of integers
 477   HashRef[CodeRef] # a hash of str to CODE ref mappings
 478   Maybe[Str]       # value may be a string, may be undefined
 479
 480 If Mouse finds a name in brackets that it does not recognize as an
 481 existing type, it assumes that this is a class name, for example
 482 C<ArrayRef[DateTime]>.
 483
 484 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 485 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 486 name, I<not> as a parameterization of C<ArrayRef>.
 487
 488 B<NOTE:> The C<Undef> type constraint for the most part works
 489 correctly now, but edge cases may still exist, please use it
 490 sparingly.
 491
 492 B<NOTE:> The C<ClassName> type constraint does a complex package
 493 existence check. This means that your class B<must> be loaded for this
 494 type constraint to pass.
 495
 496 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 497 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 498 constraint checks that an I<object does> the named role.
 499
 500 =head2 Type Constraint Naming
 501
 502 Type name declared via this module can only contain alphanumeric
 503 characters, colons (:), and periods (.).
 504
 505 Since the types created by this module are global, it is suggested
 506 that you namespace your types just as you would namespace your
 507 modules. So instead of creating a I<Color> type for your
 508 B<My::Graphics> module, you would call the type
 509 I<My::Graphics::Types::Color> instead.
 510
 511 =head2 Use with Other Constraint Modules
 512
 513 This module can play nicely with other constraint modules with some
 514 slight tweaking. The C<where> clause in types is expected to be a
 515 C<CODE> reference which checks it's first argument and returns a
 516 boolean. Since most constraint modules work in a similar way, it
 517 should be simple to adapt them to work with Mouse.
 518
 519 For instance, this is how you could use it with
 520 L<Declare::Constraints::Simple> to declare a completely new type.
 521
 522   type 'HashOfArrayOfObjects',
 523       {
 524       where => IsHashRef(
 525           -keys   => HasLength,
 526           -values => IsArrayRef(IsObject)
 527       )
 528   };
 529
 530 Here is an example of using L<Test::Deep> and it's non-test
 531 related C<eq_deeply> function.
 532
 533   type 'ArrayOfHashOfBarsAndRandomNumbers'
 534       => where {
 535           eq_deeply($_,
 536               array_each(subhashof({
 537                   bar           => isa('Bar'),
 538                   random_number => ignore()
 539               })))
 540         };
 541
 542 =head1 METHODS
 543
 544 =head2 C<< list_all_builtin_type_constraints -> (Names) >>
 545
 546 Returns the names of builtin type constraints.
 547
 548 =head2 C<< list_all_type_constraints -> (Names) >>
 549
 550 Returns the names of all the type constraints.
 551
 552 =head1 FUNCTIONS
 553
 554 =over 4
 555
 556 =item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >>
 557
 558 =item C<< subtype as 'Parent' => where { } ...  -> Mouse::Meta::TypeConstraint >>
 559
 560 =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >>
 561
 562 =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
 563
 564 =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
 565
 566 =back
 567
 568 =over 4
 569
 570 =item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >>
 571
 572 =back
 573
 574 =head1 THANKS
 575
 576 Much of this documentation was taken from C<Moose::Util::TypeConstraints>
 577
 578 =head1 SEE ALSO
 579
 580 L<Moose::Util::TypeConstraints>
 581
 582 =cut
 583
 584