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