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