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 = blessed($parent) ? $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, $code) = 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} = $code;
 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, ($types->{type_constraints} ? @{$types->{type_constraints}} : ()) ) {
 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             $_ = $COERCE{$type}->{$coerce_type}->($_); # coerce
 238
 239             if(_DEBUG){
 240                 warn sprintf "# COERCE: got %s, which is%s %s\n",
 241                     defined($_) ? $_ : 'undef', $types->check($_) ? '' : ' not', $types;
 242             }
 243
 244             return $_ if $types->check($_); # check for $types, not $constraint
 245         }
 246     }
 247     return $value;
 248 }
 249
 250 sub enum {
 251     my($name, %valid);
 252
 253     # enum ['small', 'medium', 'large']
 254     if (ref($_[0]) eq 'ARRAY') {
 255         %valid = map{ $_ => undef } @{ $_[0] };
 256         $name  = sprintf '(%s)', join '|', sort @{$_[0]};
 257     }
 258     # enum size => 'small', 'medium', 'large'
 259     else{
 260         $name  = shift;
 261         %valid = map{ $_ => undef } @_;
 262     }
 263     return _create_type 'type', $name => (
 264         optimized_as  => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} },
 265
 266         type => 'Enum',
 267     );
 268 }
 269
 270 sub _find_or_create_regular_type{
 271     my($spec)  = @_;
 272
 273     return $TYPE{$spec} if exists $TYPE{$spec};
 274
 275     my $meta  = Mouse::Meta::Module::class_of($spec);
 276
 277     if(!$meta){
 278         return;
 279     }
 280
 281     my $check;
 282     my $type;
 283     if($meta && $meta->isa('Mouse::Meta::Role')){
 284         $check = sub{
 285             return blessed($_[0]) && $_[0]->does($spec);
 286         };
 287         $type = 'Role';
 288     }
 289     else{
 290         $check = sub{
 291             return blessed($_[0]) && $_[0]->isa($spec);
 292         };
 293         $type = 'Class';
 294     }
 295
 296     warn "#CREATE a $type type for $spec\n" if _DEBUG;
 297
 298     return $TYPE{$spec} = Mouse::Meta::TypeConstraint->new(
 299         name                      => $spec,
 300         _compiled_type_constraint => $check,
 301
 302         type                      => $type,
 303     );
 304 }
 305
 306 $TYPE{ArrayRef}{constraint_generator} = sub {
 307     my($type_parameter) = @_;
 308     my $check = $type_parameter->{_compiled_type_constraint};
 309
 310     return sub{
 311         foreach my $value (@{$_}) {
 312             return undef unless $check->($value);
 313         }
 314         return 1;
 315     }
 316 };
 317 $TYPE{HashRef}{constraint_generator} = sub {
 318     my($type_parameter) = @_;
 319     my $check = $type_parameter->{_compiled_type_constraint};
 320
 321     return sub{
 322         foreach my $value(values %{$_}){
 323             return undef unless $check->($value);
 324         }
 325         return 1;
 326     };
 327 };
 328
 329 # 'Maybe' type accepts 'Any', so it requires parameters
 330 $TYPE{Maybe}{constraint_generator} = sub {
 331     my($type_parameter) = @_;
 332     my $check = $type_parameter->{_compiled_type_constraint};
 333
 334     return sub{
 335         return !defined($_) || $check->($_);
 336     };
 337 };
 338
 339 sub _find_or_create_parameterized_type{
 340     my($base, $param) = @_;
 341
 342     my $name = sprintf '%s[%s]', $base->name, $param->name;
 343
 344     $TYPE{$name} ||= do{
 345         warn "#CREATE a Parameterized type for $name\n" if _DEBUG;
 346
 347         my $generator = $base->{constraint_generator};
 348
 349         if(!$generator){
 350             confess("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
 351         }
 352
 353         Mouse::Meta::TypeConstraint->new(
 354             name               => $name,
 355             parent             => $base,
 356             constraint         => $generator->($param),
 357
 358             type               => 'Parameterized',
 359         );
 360     }
 361 }
 362 sub _find_or_create_union_type{
 363     my @types              = map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
 364
 365     my $name = join '|', map{ $_->name } @types;
 366
 367     $TYPE{$name} ||= do{
 368         warn "# CREATE a Union type for ", Mouse::Util::english_list(@types),"\n" if _DEBUG;
 369
 370         my $check = sub{
 371             foreach my $type(@types){
 372                 return 1 if $type->check($_[0]);
 373             }
 374             return 0;
 375         };
 376
 377         return Mouse::Meta::TypeConstraint->new(
 378             name                      => $name,
 379             _compiled_type_constraint => $check,
 380             type_constraints          => \@types,
 381
 382             type                      => 'Union',
 383         );
 384     };
 385 }
 386
 387 # The type parser
 388 sub _parse_type{
 389     my($spec, $start) = @_;
 390
 391     my @list;
 392     my $subtype;
 393
 394     my $len = length $spec;
 395     my $i;
 396
 397     for($i = $start; $i < $len; $i++){
 398         my $char = substr($spec, $i, 1);
 399
 400         if($char eq '['){
 401             my $base = _find_or_create_regular_type( substr($spec, $start, $i - $start))
 402                 or return;
 403
 404             ($i, $subtype) = _parse_type($spec, $i+1)
 405                 or return;
 406             $start = $i+1; # reset
 407
 408             push @list, _find_or_create_parameterized_type($base => $subtype);
 409         }
 410         elsif($char eq ']'){
 411             $len = $i+1;
 412             last;
 413         }
 414         elsif($char eq '|'){
 415             my $type = _find_or_create_regular_type( substr($spec, $start, $i - $start))
 416                 or return;
 417
 418             push @list, $type;
 419
 420             ($i, $subtype) = _parse_type($spec, $i+1)
 421                 or return;
 422
 423             $start = $i+1; # reset
 424
 425             push @list, $subtype;
 426         }
 427     }
 428     if($i - $start){
 429         push @list, _find_or_create_regular_type(substr $spec, $start, $i - $start);
 430     }
 431
 432     if(@list == 0){
 433        return;
 434     }
 435     elsif(@list == 1){
 436         return ($len, $list[0]);
 437     }
 438     else{
 439         return ($len, _find_or_create_union_type(@list));
 440     }
 441 }
 442
 443
 444 sub find_type_constraint {
 445     my($spec) = @_;
 446     return $spec if blessed($spec);
 447
 448     $spec =~ s/\s+//g;
 449     return $TYPE{$spec};
 450 }
 451
 452 sub find_or_parse_type_constraint {
 453     my($spec) = @_;
 454
 455     return $spec if blessed($spec);
 456
 457     $spec =~ s/\s+//g;
 458     return $TYPE{$spec} || do{
 459         my($pos, $type) = _parse_type($spec, 0);
 460         $type;
 461     };
 462 }
 463
 464 sub find_or_create_does_type_constraint{
 465     my $type = find_or_parse_type_constriant(@_) || role_type(@_);
 466
 467     if($type->{type} && $type->{type} ne 'Role'){
 468         Carp::cluck("$type is not a role type");
 469     }
 470     return $type;
 471 }
 472
 473 sub find_or_create_isa_type_constraint {
 474     return find_or_parse_type_constraint(@_) || class_type(@_);
 475 }
 476
 477 1;
 478
 479 __END__
 480
 481 =head1 NAME
 482
 483 Mouse::Util::TypeConstraints - Type constraint system for Mouse
 484
 485 =head2 SYNOPSIS
 486
 487   use Mouse::Util::TypeConstraints;
 488
 489   subtype 'Natural'
 490       => as 'Int'
 491       => where { $_ > 0 };
 492
 493   subtype 'NaturalLessThanTen'
 494       => as 'Natural'
 495       => where { $_ < 10 }
 496       => message { "This number ($_) is not less than ten!" };
 497
 498   coerce 'Num'
 499       => from 'Str'
 500         => via { 0+$_ };
 501
 502   enum 'RGBColors' => qw(red green blue);
 503
 504   no Mouse::Util::TypeConstraints;
 505
 506 =head1 DESCRIPTION
 507
 508 This module provides Mouse with the ability to create custom type
 509 constraints to be used in attribute definition.
 510
 511 =head2 Important Caveat
 512
 513 This is B<NOT> a type system for Perl 5. These are type constraints,
 514 and they are not used by Mouse unless you tell it to. No type
 515 inference is performed, expressions are not typed, etc. etc. etc.
 516
 517 A type constraint is at heart a small "check if a value is valid"
 518 function. A constraint can be associated with an attribute. This
 519 simplifies parameter validation, and makes your code clearer to read,
 520 because you can refer to constraints by name.
 521
 522 =head2 Slightly Less Important Caveat
 523
 524 It is B<always> a good idea to quote your type names.
 525
 526 This prevents Perl from trying to execute the call as an indirect
 527 object call. This can be an issue when you have a subtype with the
 528 same name as a valid class.
 529
 530 For instance:
 531
 532   subtype DateTime => as Object => where { $_->isa('DateTime') };
 533
 534 will I<just work>, while this:
 535
 536   use DateTime;
 537   subtype DateTime => as Object => where { $_->isa('DateTime') };
 538
 539 will fail silently and cause many headaches. The simple way to solve
 540 this, as well as future proof your subtypes from classes which have
 541 yet to have been created, is to quote the type name:
 542
 543   use DateTime;
 544   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 545
 546 =head2 Default Type Constraints
 547
 548 This module also provides a simple hierarchy for Perl 5 types, here is
 549 that hierarchy represented visually.
 550
 551   Any
 552   Item
 553       Bool
 554       Maybe[`a]
 555       Undef
 556       Defined
 557           Value
 558               Num
 559                 Int
 560               Str
 561                 ClassName
 562                 RoleName
 563           Ref
 564               ScalarRef
 565               ArrayRef[`a]
 566               HashRef[`a]
 567               CodeRef
 568               RegexpRef
 569               GlobRef
 570                 FileHandle
 571               Object
 572                 Role
 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