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