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