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