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