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