lib/Mouse/Util/TypeConstraints.pm

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