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