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