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     my $name = $constraint->name;
 387     Carp::croak("Can't register an unnamed type constraint")
 388         unless defined $name;
 389     return $TYPE{$name} = $constraint;
 390 }
 391
 392 sub find_or_parse_type_constraint {
 393     my($spec) = @_;
 394     return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec;
 395
 396     $spec =~ tr/ \t\r\n//d;
 397
 398     my $tc = $TYPE{$spec};
 399     if(defined $tc) {
 400         return $tc;
 401     }
 402
 403     my %context = (
 404         spec => $spec,
 405         orig => $spec,
 406     );
 407     $tc = _parse_type(\%context);
 408
 409     if($context{spec}){
 410         Carp::croak("Syntax error: extra elements '$context{spec}' in '$context{orig}'");
 411     }
 412
 413     return $TYPE{$spec} = $tc;
 414 }
 415
 416 sub find_or_create_does_type_constraint{
 417     # XXX: Moose does not register a new role_type, but Mouse does.
 418     my $tc = find_or_parse_type_constraint(@_);
 419     return defined($tc) ? $tc : role_type(@_);
 420 }
 421
 422 sub find_or_create_isa_type_constraint {
 423     # XXX: Moose does not register a new class_type, but Mouse does.
 424     my $tc = find_or_parse_type_constraint(@_);
 425     return defined($tc) ? $tc : class_type(@_);
 426 }
 427
 428 1;
 429 __END__
 430
 431 =head1 NAME
 432
 433 Mouse::Util::TypeConstraints - Type constraint system for Mouse
 434
 435 =head1 VERSION
 436
 437 This document describes Mouse version 0.82
 438
 439 =head2 SYNOPSIS
 440
 441   use Mouse::Util::TypeConstraints;
 442
 443   subtype 'Natural'
 444       => as 'Int'
 445       => where { $_ > 0 };
 446
 447   subtype 'NaturalLessThanTen'
 448       => as 'Natural'
 449       => where { $_ < 10 }
 450       => message { "This number ($_) is not less than ten!" };
 451
 452   coerce 'Num'
 453       => from 'Str'
 454         => via { 0+$_ };
 455
 456   enum 'RGBColors' => qw(red green blue);
 457
 458   no Mouse::Util::TypeConstraints;
 459
 460 =head1 DESCRIPTION
 461
 462 This module provides Mouse with the ability to create custom type
 463 constraints to be used in attribute definition.
 464
 465 =head2 Important Caveat
 466
 467 This is B<NOT> a type system for Perl 5. These are type constraints,
 468 and they are not used by Mouse unless you tell it to. No type
 469 inference is performed, expressions are not typed, etc. etc. etc.
 470
 471 A type constraint is at heart a small "check if a value is valid"
 472 function. A constraint can be associated with an attribute. This
 473 simplifies parameter validation, and makes your code clearer to read,
 474 because you can refer to constraints by name.
 475
 476 =head2 Slightly Less Important Caveat
 477
 478 It is B<always> a good idea to quote your type names.
 479
 480 This prevents Perl from trying to execute the call as an indirect
 481 object call. This can be an issue when you have a subtype with the
 482 same name as a valid class.
 483
 484 For instance:
 485
 486   subtype DateTime => as Object => where { $_->isa('DateTime') };
 487
 488 will I<just work>, while this:
 489
 490   use DateTime;
 491   subtype DateTime => as Object => where { $_->isa('DateTime') };
 492
 493 will fail silently and cause many headaches. The simple way to solve
 494 this, as well as future proof your subtypes from classes which have
 495 yet to have been created, is to quote the type name:
 496
 497   use DateTime;
 498   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 499
 500 =head2 Default Type Constraints
 501
 502 This module also provides a simple hierarchy for Perl 5 types, here is
 503 that hierarchy represented visually.
 504
 505  Any
 506   Item
 507       Bool
 508       Maybe[`a]
 509       Undef
 510       Defined
 511           Value
 512               Str
 513                   Num
 514                       Int
 515                   ClassName
 516                   RoleName
 517           Ref
 518               ScalarRef
 519               ArrayRef[`a]
 520               HashRef[`a]
 521               CodeRef
 522               RegexpRef
 523               GlobRef
 524                   FileHandle
 525               Object
 526
 527 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 528 parameterized, this means you can say:
 529
 530   ArrayRef[Int]    # an array of integers
 531   HashRef[CodeRef] # a hash of str to CODE ref mappings
 532   Maybe[Str]       # value may be a string, may be undefined
 533
 534 If Mouse finds a name in brackets that it does not recognize as an
 535 existing type, it assumes that this is a class name, for example
 536 C<ArrayRef[DateTime]>.
 537
 538 B<NOTE:> The C<Undef> type constraint for the most part works
 539 correctly now, but edge cases may still exist, please use it
 540 sparingly.
 541
 542 B<NOTE:> The C<ClassName> type constraint does a complex package
 543 existence check. This means that your class B<must> be loaded for this
 544 type constraint to pass.
 545
 546 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 547 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 548 constraint checks that an I<object does> the named role.
 549
 550 =head2 Type Constraint Naming
 551
 552 Type name declared via this module can only contain alphanumeric
 553 characters, colons (:), and periods (.).
 554
 555 Since the types created by this module are global, it is suggested
 556 that you namespace your types just as you would namespace your
 557 modules. So instead of creating a I<Color> type for your
 558 B<My::Graphics> module, you would call the type
 559 I<My::Graphics::Types::Color> instead.
 560
 561 =head2 Use with Other Constraint Modules
 562
 563 This module can play nicely with other constraint modules with some
 564 slight tweaking. The C<where> clause in types is expected to be a
 565 C<CODE> reference which checks it's first argument and returns a
 566 boolean. Since most constraint modules work in a similar way, it
 567 should be simple to adapt them to work with Mouse.
 568
 569 For instance, this is how you could use it with
 570 L<Declare::Constraints::Simple> to declare a completely new type.
 571
 572   type 'HashOfArrayOfObjects',
 573       {
 574       where => IsHashRef(
 575           -keys   => HasLength,
 576           -values => IsArrayRef(IsObject)
 577       )
 578   };
 579
 580 Here is an example of using L<Test::Deep> and it's non-test
 581 related C<eq_deeply> function.
 582
 583   type 'ArrayOfHashOfBarsAndRandomNumbers'
 584       => where {
 585           eq_deeply($_,
 586               array_each(subhashof({
 587                   bar           => isa('Bar'),
 588                   random_number => ignore()
 589               })))
 590         };
 591
 592 =head1 METHODS
 593
 594 =head2 C<< list_all_builtin_type_constraints -> (Names) >>
 595
 596 Returns the names of builtin type constraints.
 597
 598 =head2 C<< list_all_type_constraints -> (Names) >>
 599
 600 Returns the names of all the type constraints.
 601
 602 =head1 FUNCTIONS
 603
 604 =over 4
 605
 606 =item C<< type $name => where { } ... -> Mouse::Meta::TypeConstraint >>
 607
 608 =item C<< subtype $name => as $parent => where { } ... -> Mouse::Meta::TypeConstraint >>
 609
 610 =item C<< subtype as $parent => where { } ...  -> Mouse::Meta::TypeConstraint >>
 611
 612 =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >>
 613
 614 =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
 615
 616 =item C<< duck_type($name, @methods | \@methods) -> Mouse::Meta::TypeConstraint >>
 617
 618 =item C<< duck_type(\@methods) -> Mouse::Meta::TypeConstraint >>
 619
 620 =item C<< enum($name, @values | \@values) -> Mouse::Meta::TypeConstraint >>
 621
 622 =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
 623
 624 =item C<< coerce $type => from $another_type, via { }, ... >>
 625
 626 =back
 627
 628 =over 4
 629
 630 =item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >>
 631
 632 =back
 633
 634 =head1 THANKS
 635
 636 Much of this documentation was taken from C<Moose::Util::TypeConstraints>
 637
 638 =head1 SEE ALSO
 639
 640 L<Moose::Util::TypeConstraints>
 641
 642 =cut
 643
 644