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