lib/Mouse/Util/TypeConstraints.pm

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