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