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