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