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