lib/Mouse/Util/TypeConstraints.pm

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