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