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