lib/Mouse/Util/TypeConstraints.pm

   1 package Mouse::Util::TypeConstraints;
   2 use Mouse::Util; # 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 _define_type {
 108     my $is_subtype = shift;
 109     my $name;
 110     my %args;
 111
 112     if(@_ == 1 && ref $_[0] ){    # @_ : { name => $name, where => ... }
 113         %args = %{$_[0]};
 114     }
 115     elsif(@_ == 2 && ref $_[1]) { # @_ : $name => { where => ... }
 116         $name = $_[0];
 117         %args = %{$_[1]};
 118     }
 119     elsif(@_ % 2) {               # @_ : $name => ( where => ... )
 120         ($name, %args) = @_;
 121     }
 122     else{                         # @_ : (name => $name, where => ...)
 123         %args = @_;
 124     }
 125
 126     if(!defined $name){
 127         $name = $args{name};
 128     }
 129
 130     $args{name} = $name;
 131
 132     my $parent = delete $args{as};
 133     if($is_subtype && !$parent){
 134         $parent = delete $args{name};
 135         $name   = undef;
 136     }
 137
 138     if(defined $parent) {
 139         $args{parent} = find_or_create_isa_type_constraint($parent);
 140     }
 141
 142     if(defined $name){
 143         # set 'package_defined_in' only if it is not a core package
 144         my $this = $args{package_defined_in};
 145         if(!$this){
 146             $this = caller(1);
 147             if($this !~ /\A Mouse \b/xms){
 148                 $args{package_defined_in} = $this;
 149             }
 150         }
 151
 152         if($TYPE{$name}){
 153             my $that = $TYPE{$name}->{package_defined_in} || __PACKAGE__;
 154             if($this ne $that) {
 155                 my $note = '';
 156                 if($that eq __PACKAGE__) {
 157                     $note = sprintf " ('%s' is %s type constraint)",
 158                         $name,
 159                         scalar(grep { $name eq $_ } list_all_builtin_type_constraints())
 160                             ? 'a builtin'
 161                             : 'an implicitly created';
 162                 }
 163                 Carp::croak("The type constraint '$name' has already been created in $that"
 164                           . " and cannot be created again in $this" . $note);
 165             }
 166         }
 167     }
 168
 169     $args{constraint} = delete $args{where}        if exists $args{where};
 170     $args{optimized}  = delete $args{optimized_as} if exists $args{optimized_as};
 171
 172     my $constraint = Mouse::Meta::TypeConstraint->new(%args);
 173
 174     if(defined $name){
 175         return $TYPE{$name} = $constraint;
 176     }
 177     else{
 178         return $constraint;
 179     }
 180 }
 181
 182 sub type {
 183     return _define_type 0, @_;
 184 }
 185
 186 sub subtype {
 187     return _define_type 1, @_;
 188 }
 189
 190 sub coerce {
 191     my $type_name = shift;
 192
 193     my $type = find_type_constraint($type_name)
 194         or Carp::croak("Cannot find type '$type_name', perhaps you forgot to load it.");
 195
 196     $type->_add_type_coercions(@_);
 197     return;
 198 }
 199
 200 sub class_type {
 201     my($name, $options) = @_;
 202     my $class = $options->{class} || $name;
 203
 204     # ClassType
 205     return _define_type 1, $name => (
 206         as           => 'Object',
 207         optimized_as => Mouse::Util::generate_isa_predicate_for($class),
 208         class        => $class,
 209     );
 210 }
 211
 212 sub role_type {
 213     my($name, $options) = @_;
 214     my $role = $options->{role} || $name;
 215
 216     # RoleType
 217     return _define_type 1, $name => (
 218         as           => 'Object',
 219         optimized_as => sub {
 220             return Scalar::Util::blessed($_[0])
 221                 && Mouse::Util::does_role($_[0], $role);
 222         },
 223         role         => $role,
 224     );
 225 }
 226
 227 sub duck_type {
 228     my($name, @methods);
 229
 230     if(ref($_[0]) ne 'ARRAY'){
 231         $name = shift;
 232     }
 233
 234     @methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_;
 235
 236     # DuckType
 237     return _define_type 1, $name => (
 238         as           => 'Object',
 239         optimized_as => Mouse::Util::generate_can_predicate_for(\@methods),
 240         message      => sub {
 241             my($object) = @_;
 242             my @missing = grep { !$object->can($_) } @methods;
 243             return ref($object)
 244                 . ' is missing methods '
 245                 . Mouse::Util::quoted_english_list(@missing);
 246         },
 247         methods      => \@methods,
 248     );
 249 }
 250
 251 sub enum {
 252     my($name, %valid);
 253
 254     if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){
 255         $name = shift;
 256     }
 257
 258     %valid = map{ $_ => undef }
 259         (@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_);
 260
 261     # EnumType
 262     return _define_type 1, $name => (
 263         as            => 'Str',
 264         optimized_as  => sub{
 265             return defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]};
 266         },
 267     );
 268 }
 269
 270 sub _find_or_create_regular_type{
 271     my($spec, $create)  = @_;
 272
 273     return $TYPE{$spec} if exists $TYPE{$spec};
 274
 275     my $meta = Mouse::Util::get_metaclass_by_name($spec);
 276
 277     if(!defined $meta){
 278         return $create ? class_type($spec) : undef;
 279     }
 280
 281     if(Mouse::Util::is_a_metarole($meta)){
 282         return role_type($spec);
 283     }
 284     else{
 285         return class_type($spec);
 286     }
 287 }
 288
 289 sub _find_or_create_parameterized_type{
 290     my($base, $param) = @_;
 291
 292     my $name = sprintf '%s[%s]', $base->name, $param->name;
 293
 294     $TYPE{$name} ||= $base->parameterize($param, $name);
 295 }
 296
 297 sub _find_or_create_union_type{
 298     return if grep{ not defined } @_;
 299     my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
 300
 301     my $name = join '|', @types;
 302
 303     # UnionType
 304     $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new(
 305         name              => $name,
 306         type_constraints  => \@types,
 307     );
 308 }
 309
 310 # The type parser
 311
 312 # param : '[' type ']' | NOTHING
 313 sub _parse_param {
 314     my($c) = @_;
 315
 316     if($c->{spec} =~ s/^\[//){
 317         my $type = _parse_type($c, 1);
 318
 319         if($c->{spec} =~ s/^\]//){
 320             return $type;
 321         }
 322         Carp::croak("Syntax error in type: missing right square bracket in '$c->{orig}'");
 323     }
 324
 325     return undef;
 326 }
 327
 328 # name : [\w.:]+
 329 sub _parse_name {
 330     my($c, $create) = @_;
 331
 332     if($c->{spec} =~ s/\A ([\w.:]+) //xms){
 333         return _find_or_create_regular_type($1, $create);
 334     }
 335     Carp::croak("Syntax error in type: expect type name near '$c->{spec}' in '$c->{orig}'");
 336 }
 337
 338 # single_type : name param
 339 sub _parse_single_type {
 340     my($c, $create) = @_;
 341
 342     my $type  = _parse_name($c, $create);
 343     my $param = _parse_param($c);
 344
 345     if(defined $type){
 346         if(defined $param){
 347             return _find_or_create_parameterized_type($type, $param);
 348         }
 349         else {
 350             return $type;
 351         }
 352     }
 353     elsif(defined $param){
 354         Carp::croak("Undefined type with parameter [$param] in '$c->{orig}'");
 355     }
 356     else{
 357         return undef;
 358     }
 359 }
 360
 361 # type : single_type  ('|' single_type)*
 362 sub _parse_type {
 363     my($c, $create) = @_;
 364
 365     my $type = _parse_single_type($c, $create);
 366     if($c->{spec}){ # can be an union type
 367         my @types;
 368         while($c->{spec} =~ s/^\|//){
 369             push @types, _parse_single_type($c, $create);
 370         }
 371         if(@types){
 372             return _find_or_create_union_type($type, @types);
 373         }
 374     }
 375     return $type;
 376 }
 377
 378
 379 sub find_type_constraint {
 380     my($spec) = @_;
 381     return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec;
 382
 383     $spec =~ s/\s+//g;
 384     return $TYPE{$spec};
 385 }
 386
 387 sub register_type_constraint {
 388     my($constraint) = @_;
 389     Carp::croak("No type supplied / type is not a valid type constraint")
 390         unless Mouse::Util::is_a_type_constraint($constraint);
 391     my $name = $constraint->name;
 392     Carp::croak("Can't register an unnamed type constraint")
 393         unless defined $name;
 394     return $TYPE{$name} = $constraint;
 395 }
 396
 397 sub find_or_parse_type_constraint {
 398     my($spec) = @_;
 399     return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec;
 400
 401     $spec =~ s/\s+//g;
 402     return $TYPE{$spec} || do{
 403         my $context = {
 404             spec => $spec,
 405             orig => $spec,
 406         };
 407         my $type = _parse_type($context);
 408
 409         if($context->{spec}){
 410             Carp::croak("Syntax error: extra elements '$context->{spec}' in '$context->{orig}'");
 411         }
 412         $type;
 413     };
 414 }
 415
 416 sub find_or_create_does_type_constraint{
 417     # XXX: Moose does not register a new role_type, but Mouse does.
 418     return find_or_parse_type_constraint(@_) || role_type(@_);
 419 }
 420
 421 sub find_or_create_isa_type_constraint {
 422     # XXX: Moose does not register a new class_type, but Mouse does.
 423     return find_or_parse_type_constraint(@_) || 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.72
 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