lib/Mouse/Util/TypeConstraints.pm

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