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