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->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
 419             # XXX: Currently Mouse create an anonymous type for backward compatibility
 420             if(!defined $type){
 421                 my $class = substr($spec, $start, $i - $start);
 422                 $type = Mouse::Meta::TypeConstraint->new(
 423                     name                      => $class,
 424                     _compiled_type_constraint => sub{ blessed($_[0]) && $_[0]->isa($class) },
 425                 );
 426             }
 427
 428             push @list, $type;
 429
 430             ($i, $subtype) = _parse_type($spec, $i+1)
 431                 or return;
 432
 433             $start = $i+1; # reset
 434
 435             push @list, $subtype;
 436         }
 437     }
 438     if($i - $start){
 439         push @list, _find_or_create_regular_type(substr $spec, $start, $i - $start);
 440     }
 441
 442     if(@list == 0){
 443        return;
 444     }
 445     elsif(@list == 1){
 446         return ($len, $list[0]);
 447     }
 448     else{
 449         return ($len, _find_or_create_union_type(@list));
 450     }
 451 }
 452
 453
 454 sub find_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};
 460 }
 461
 462 sub find_or_parse_type_constraint {
 463     my($spec) = @_;
 464     return $spec if blessed($spec) && $spec->isa('Mouse::Meta::TypeConstraint');
 465
 466     $spec =~ s/\s+//g;
 467     return $TYPE{$spec} || do{
 468         my($pos, $type) = _parse_type($spec, 0);
 469         $type;
 470     };
 471 }
 472
 473 sub find_or_create_does_type_constraint{
 474     my $type = find_or_parse_type_constriant(@_) || role_type(@_);
 475
 476     if($type->{type} && $type->{type} ne 'Role'){
 477         Carp::cluck("$type is not a role type");
 478     }
 479     return $type;
 480 }
 481
 482 sub find_or_create_isa_type_constraint {
 483     return find_or_parse_type_constraint(@_) || class_type(@_);
 484 }
 485
 486 1;
 487
 488 __END__
 489
 490 =head1 NAME
 491
 492 Mouse::Util::TypeConstraints - Type constraint system for Mouse
 493
 494 =head2 SYNOPSIS
 495
 496   use Mouse::Util::TypeConstraints;
 497
 498   subtype 'Natural'
 499       => as 'Int'
 500       => where { $_ > 0 };
 501
 502   subtype 'NaturalLessThanTen'
 503       => as 'Natural'
 504       => where { $_ < 10 }
 505       => message { "This number ($_) is not less than ten!" };
 506
 507   coerce 'Num'
 508       => from 'Str'
 509         => via { 0+$_ };
 510
 511   enum 'RGBColors' => qw(red green blue);
 512
 513   no Mouse::Util::TypeConstraints;
 514
 515 =head1 DESCRIPTION
 516
 517 This module provides Mouse with the ability to create custom type
 518 constraints to be used in attribute definition.
 519
 520 =head2 Important Caveat
 521
 522 This is B<NOT> a type system for Perl 5. These are type constraints,
 523 and they are not used by Mouse unless you tell it to. No type
 524 inference is performed, expressions are not typed, etc. etc. etc.
 525
 526 A type constraint is at heart a small "check if a value is valid"
 527 function. A constraint can be associated with an attribute. This
 528 simplifies parameter validation, and makes your code clearer to read,
 529 because you can refer to constraints by name.
 530
 531 =head2 Slightly Less Important Caveat
 532
 533 It is B<always> a good idea to quote your type names.
 534
 535 This prevents Perl from trying to execute the call as an indirect
 536 object call. This can be an issue when you have a subtype with the
 537 same name as a valid class.
 538
 539 For instance:
 540
 541   subtype DateTime => as Object => where { $_->isa('DateTime') };
 542
 543 will I<just work>, while this:
 544
 545   use DateTime;
 546   subtype DateTime => as Object => where { $_->isa('DateTime') };
 547
 548 will fail silently and cause many headaches. The simple way to solve
 549 this, as well as future proof your subtypes from classes which have
 550 yet to have been created, is to quote the type name:
 551
 552   use DateTime;
 553   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 554
 555 =head2 Default Type Constraints
 556
 557 This module also provides a simple hierarchy for Perl 5 types, here is
 558 that hierarchy represented visually.
 559
 560   Any
 561   Item
 562       Bool
 563       Maybe[`a]
 564       Undef
 565       Defined
 566           Value
 567               Num
 568                 Int
 569               Str
 570                 ClassName
 571                 RoleName
 572           Ref
 573               ScalarRef
 574               ArrayRef[`a]
 575               HashRef[`a]
 576               CodeRef
 577               RegexpRef
 578               GlobRef
 579                 FileHandle
 580               Object
 581
 582 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 583 parameterized, this means you can say:
 584
 585   ArrayRef[Int]    # an array of integers
 586   HashRef[CodeRef] # a hash of str to CODE ref mappings
 587   Maybe[Str]       # value may be a string, may be undefined
 588
 589 If Mouse finds a name in brackets that it does not recognize as an
 590 existing type, it assumes that this is a class name, for example
 591 C<ArrayRef[DateTime]>.
 592
 593 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 594 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 595 name, I<not> as a parameterization of C<ArrayRef>.
 596
 597 B<NOTE:> The C<Undef> type constraint for the most part works
 598 correctly now, but edge cases may still exist, please use it
 599 sparingly.
 600
 601 B<NOTE:> The C<ClassName> type constraint does a complex package
 602 existence check. This means that your class B<must> be loaded for this
 603 type constraint to pass.
 604
 605 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 606 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 607 constraint checks that an I<object does> the named role.
 608
 609 =head2 Type Constraint Naming
 610
 611 Type name declared via this module can only contain alphanumeric
 612 characters, colons (:), and periods (.).
 613
 614 Since the types created by this module are global, it is suggested
 615 that you namespace your types just as you would namespace your
 616 modules. So instead of creating a I<Color> type for your
 617 B<My::Graphics> module, you would call the type
 618 I<My::Graphics::Types::Color> instead.
 619
 620 =head2 Use with Other Constraint Modules
 621
 622 This module can play nicely with other constraint modules with some
 623 slight tweaking. The C<where> clause in types is expected to be a
 624 C<CODE> reference which checks it's first argument and returns a
 625 boolean. Since most constraint modules work in a similar way, it
 626 should be simple to adapt them to work with Mouse.
 627
 628 For instance, this is how you could use it with
 629 L<Declare::Constraints::Simple> to declare a completely new type.
 630
 631   type 'HashOfArrayOfObjects',
 632       {
 633       where => IsHashRef(
 634           -keys   => HasLength,
 635           -values => IsArrayRef(IsObject)
 636       )
 637   };
 638
 639 Here is an example of using L<Test::Deep> and it's non-test
 640 related C<eq_deeply> function.
 641
 642   type 'ArrayOfHashOfBarsAndRandomNumbers'
 643       => where {
 644           eq_deeply($_,
 645               array_each(subhashof({
 646                   bar           => isa('Bar'),
 647                   random_number => ignore()
 648               })))
 649         };
 650
 651 =head1 METHODS
 652
 653 =head2 optimized_constraints -> HashRef[CODE]
 654
 655 Returns the simple type constraints that Mouse understands.
 656
 657 =head1 FUNCTIONS
 658
 659 =over 4
 660
 661 =item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >>
 662
 663 =item C<< subtype as 'Parent' => where { } ...  -> Mouse::Meta::TypeConstraint >>
 664
 665 =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >>
 666
 667 =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
 668
 669 =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
 670
 671 =back
 672
 673 =over 4
 674
 675 =item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >>
 676
 677 =back
 678
 679 =head1 THANKS
 680
 681 Much of this documentation was taken from C<Moose::Util::TypeConstraints>
 682
 683 =head1 SEE ALSO
 684
 685 L<Moose::Util::TypeConstraints>
 686
 687 =cut
 688
 689