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