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 # 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 { Scalar::Util::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     # XXX: Moose does not register a new role_type, but Mouse does.
 388     return find_or_parse_type_constraint(@_) || role_type(@_);
 389 }
 390
 391 sub find_or_create_isa_type_constraint {
 392     # XXX: Moose does not register a new class_type, but Mouse does.
 393     return find_or_parse_type_constraint(@_) || class_type(@_);
 394 }
 395
 396 1;
 397
 398 __END__
 399
 400 =head1 NAME
 401
 402 Mouse::Util::TypeConstraints - Type constraint system for Mouse
 403
 404 =head1 VERSION
 405
 406 This document describes Mouse version 0.40_02
 407
 408 =head2 SYNOPSIS
 409
 410   use Mouse::Util::TypeConstraints;
 411
 412   subtype 'Natural'
 413       => as 'Int'
 414       => where { $_ > 0 };
 415
 416   subtype 'NaturalLessThanTen'
 417       => as 'Natural'
 418       => where { $_ < 10 }
 419       => message { "This number ($_) is not less than ten!" };
 420
 421   coerce 'Num'
 422       => from 'Str'
 423         => via { 0+$_ };
 424
 425   enum 'RGBColors' => qw(red green blue);
 426
 427   no Mouse::Util::TypeConstraints;
 428
 429 =head1 DESCRIPTION
 430
 431 This module provides Mouse with the ability to create custom type
 432 constraints to be used in attribute definition.
 433
 434 =head2 Important Caveat
 435
 436 This is B<NOT> a type system for Perl 5. These are type constraints,
 437 and they are not used by Mouse unless you tell it to. No type
 438 inference is performed, expressions are not typed, etc. etc. etc.
 439
 440 A type constraint is at heart a small "check if a value is valid"
 441 function. A constraint can be associated with an attribute. This
 442 simplifies parameter validation, and makes your code clearer to read,
 443 because you can refer to constraints by name.
 444
 445 =head2 Slightly Less Important Caveat
 446
 447 It is B<always> a good idea to quote your type names.
 448
 449 This prevents Perl from trying to execute the call as an indirect
 450 object call. This can be an issue when you have a subtype with the
 451 same name as a valid class.
 452
 453 For instance:
 454
 455   subtype DateTime => as Object => where { $_->isa('DateTime') };
 456
 457 will I<just work>, while this:
 458
 459   use DateTime;
 460   subtype DateTime => as Object => where { $_->isa('DateTime') };
 461
 462 will fail silently and cause many headaches. The simple way to solve
 463 this, as well as future proof your subtypes from classes which have
 464 yet to have been created, is to quote the type name:
 465
 466   use DateTime;
 467   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 468
 469 =head2 Default Type Constraints
 470
 471 This module also provides a simple hierarchy for Perl 5 types, here is
 472 that hierarchy represented visually.
 473
 474   Any
 475   Item
 476       Bool
 477       Maybe[`a]
 478       Undef
 479       Defined
 480           Value
 481               Num
 482                 Int
 483               Str
 484                 ClassName
 485                 RoleName
 486           Ref
 487               ScalarRef
 488               ArrayRef[`a]
 489               HashRef[`a]
 490               CodeRef
 491               RegexpRef
 492               GlobRef
 493                 FileHandle
 494               Object
 495
 496 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 497 parameterized, this means you can say:
 498
 499   ArrayRef[Int]    # an array of integers
 500   HashRef[CodeRef] # a hash of str to CODE ref mappings
 501   Maybe[Str]       # value may be a string, may be undefined
 502
 503 If Mouse finds a name in brackets that it does not recognize as an
 504 existing type, it assumes that this is a class name, for example
 505 C<ArrayRef[DateTime]>.
 506
 507 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 508 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 509 name, I<not> as a parameterization of C<ArrayRef>.
 510
 511 B<NOTE:> The C<Undef> type constraint for the most part works
 512 correctly now, but edge cases may still exist, please use it
 513 sparingly.
 514
 515 B<NOTE:> The C<ClassName> type constraint does a complex package
 516 existence check. This means that your class B<must> be loaded for this
 517 type constraint to pass.
 518
 519 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 520 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 521 constraint checks that an I<object does> the named role.
 522
 523 =head2 Type Constraint Naming
 524
 525 Type name declared via this module can only contain alphanumeric
 526 characters, colons (:), and periods (.).
 527
 528 Since the types created by this module are global, it is suggested
 529 that you namespace your types just as you would namespace your
 530 modules. So instead of creating a I<Color> type for your
 531 B<My::Graphics> module, you would call the type
 532 I<My::Graphics::Types::Color> instead.
 533
 534 =head2 Use with Other Constraint Modules
 535
 536 This module can play nicely with other constraint modules with some
 537 slight tweaking. The C<where> clause in types is expected to be a
 538 C<CODE> reference which checks it's first argument and returns a
 539 boolean. Since most constraint modules work in a similar way, it
 540 should be simple to adapt them to work with Mouse.
 541
 542 For instance, this is how you could use it with
 543 L<Declare::Constraints::Simple> to declare a completely new type.
 544
 545   type 'HashOfArrayOfObjects',
 546       {
 547       where => IsHashRef(
 548           -keys   => HasLength,
 549           -values => IsArrayRef(IsObject)
 550       )
 551   };
 552
 553 Here is an example of using L<Test::Deep> and it's non-test
 554 related C<eq_deeply> function.
 555
 556   type 'ArrayOfHashOfBarsAndRandomNumbers'
 557       => where {
 558           eq_deeply($_,
 559               array_each(subhashof({
 560                   bar           => isa('Bar'),
 561                   random_number => ignore()
 562               })))
 563         };
 564
 565 =head1 METHODS
 566
 567 =head2 C<< list_all_builtin_type_constraints -> (Names) >>
 568
 569 Returns the names of builtin type constraints.
 570
 571 =head2 C<< list_all_type_constraints -> (Names) >>
 572
 573 Returns the names of all the type constraints.
 574
 575 =head1 FUNCTIONS
 576
 577 =over 4
 578
 579 =item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >>
 580
 581 =item C<< subtype as 'Parent' => where { } ...  -> Mouse::Meta::TypeConstraint >>
 582
 583 =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >>
 584
 585 =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
 586
 587 =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
 588
 589 =back
 590
 591 =over 4
 592
 593 =item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >>
 594
 595 =back
 596
 597 =head1 THANKS
 598
 599 Much of this documentation was taken from C<Moose::Util::TypeConstraints>
 600
 601 =head1 SEE ALSO
 602
 603 L<Moose::Util::TypeConstraints>
 604
 605 =cut
 606
 607