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