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