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