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 $type_name = shift;
 154
 155     my $type = find_type_constraint($type_name)
 156         or confess("Cannot find type '$type_name', perhaps you forgot to load it.");
 157
 158     $type->_add_type_coercions(@_);
 159     return;
 160 }
 161
 162 sub class_type {
 163     my($name, $conf) = @_;
 164     if ($conf && $conf->{class}) {
 165         # No, you're using this wrong
 166         warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?";
 167         _create_type 'type', $name => (
 168             as   => $conf->{class},
 169
 170             type => 'Class',
 171        );
 172     }
 173     else {
 174         _create_type 'type', $name => (
 175             optimized_as => sub { blessed($_[0]) && $_[0]->isa($name) },
 176
 177             type => 'Class',
 178         );
 179     }
 180 }
 181
 182 sub role_type {
 183     my($name, $conf) = @_;
 184     my $role = ($conf && $conf->{role}) ? $conf->{role} : $name;
 185     _create_type 'type', $name => (
 186         optimized_as => sub { blessed($_[0]) && does_role($_[0], $role) },
 187
 188         type => 'Role',
 189     );
 190 }
 191
 192 # this is an original method for Mouse
 193 sub typecast_constraints {
 194     my($class, $pkg, $type, $value) = @_;
 195     Carp::croak("wrong arguments count") unless @_ == 4;
 196
 197     return $type->coerce($value);
 198 }
 199
 200 sub enum {
 201     my($name, %valid);
 202
 203     # enum ['small', 'medium', 'large']
 204     if (ref($_[0]) eq 'ARRAY') {
 205         %valid = map{ $_ => undef } @{ $_[0] };
 206         $name  = sprintf '(%s)', join '|', sort @{$_[0]};
 207     }
 208     # enum size => 'small', 'medium', 'large'
 209     else{
 210         $name  = shift;
 211         %valid = map{ $_ => undef } @_;
 212     }
 213     return _create_type 'type', $name => (
 214         optimized_as  => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} },
 215
 216         type => 'Enum',
 217     );
 218 }
 219
 220 sub _find_or_create_regular_type{
 221     my($spec)  = @_;
 222
 223     return $TYPE{$spec} if exists $TYPE{$spec};
 224
 225     my $meta  = Mouse::Meta::Module::class_of($spec);
 226
 227     if(!$meta){
 228         return;
 229     }
 230
 231     my $check;
 232     my $type;
 233     if($meta->isa('Mouse::Meta::Role')){
 234         $check = sub{
 235             return blessed($_[0]) && $_[0]->does($spec);
 236         };
 237         $type = 'Role';
 238     }
 239     else{
 240         $check = sub{
 241             return blessed($_[0]) && $_[0]->isa($spec);
 242         };
 243         $type = 'Class';
 244     }
 245
 246     warn "#CREATE a $type type for $spec\n" if _DEBUG;
 247
 248     return $TYPE{$spec} = Mouse::Meta::TypeConstraint->new(
 249         name      => $spec,
 250         optimized => $check,
 251
 252         type      => $type,
 253     );
 254 }
 255
 256 $TYPE{ArrayRef}{constraint_generator} = sub {
 257     my($type_parameter) = @_;
 258     my $check = $type_parameter->_compiled_type_constraint;
 259
 260     return sub{
 261         foreach my $value (@{$_}) {
 262             return undef unless $check->($value);
 263         }
 264         return 1;
 265     }
 266 };
 267 $TYPE{HashRef}{constraint_generator} = sub {
 268     my($type_parameter) = @_;
 269     my $check = $type_parameter->_compiled_type_constraint;
 270
 271     return sub{
 272         foreach my $value(values %{$_}){
 273             return undef unless $check->($value);
 274         }
 275         return 1;
 276     };
 277 };
 278
 279 # 'Maybe' type accepts 'Any', so it requires parameters
 280 $TYPE{Maybe}{constraint_generator} = sub {
 281     my($type_parameter) = @_;
 282     my $check = $type_parameter->_compiled_type_constraint;
 283
 284     return sub{
 285         return !defined($_) || $check->($_);
 286     };
 287 };
 288
 289 sub _find_or_create_parameterized_type{
 290     my($base, $param) = @_;
 291
 292     my $name = sprintf '%s[%s]', $base->name, $param->name;
 293
 294     $TYPE{$name} ||= do{
 295         warn "#CREATE a Parameterized type for $name\n" if _DEBUG;
 296
 297         my $generator = $base->{constraint_generator};
 298
 299         if(!$generator){
 300             confess("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
 301         }
 302
 303         Mouse::Meta::TypeConstraint->new(
 304             name               => $name,
 305             parent             => $base,
 306             constraint         => $generator->($param),
 307
 308             type               => 'Parameterized',
 309         );
 310     }
 311 }
 312 sub _find_or_create_union_type{
 313     my @types = map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
 314
 315     my $name = join '|', map{ $_->name } @types;
 316
 317     $TYPE{$name} ||= do{
 318         warn "# CREATE a Union type for ", Mouse::Util::english_list(@types),"\n" if _DEBUG;
 319
 320         return Mouse::Meta::TypeConstraint->new(
 321             name              => $name,
 322             type_constraints  => \@types,
 323
 324             type              => 'Union',
 325         );
 326     };
 327 }
 328
 329 # The type parser
 330 sub _parse_type{
 331     my($spec, $start) = @_;
 332
 333     my @list;
 334     my $subtype;
 335
 336     my $len = length $spec;
 337     my $i;
 338
 339     for($i = $start; $i < $len; $i++){
 340         my $char = substr($spec, $i, 1);
 341
 342         if($char eq '['){
 343             my $base = _find_or_create_regular_type( substr($spec, $start, $i - $start) )
 344                 or return;
 345
 346             ($i, $subtype) = _parse_type($spec, $i+1)
 347                 or return;
 348             $start = $i+1; # reset
 349
 350             push @list, _find_or_create_parameterized_type($base => $subtype);
 351         }
 352         elsif($char eq ']'){
 353             $len = $i+1;
 354             last;
 355         }
 356         elsif($char eq '|'){
 357             my $type = _find_or_create_regular_type( substr($spec, $start, $i - $start) );
 358
 359             if(!defined $type){
 360                 # XXX: Mouse creates a new class type, but Moose does not.
 361                 $type = class_type( substr($spec, $start, $i - $start) );
 362             }
 363
 364             push @list, $type;
 365
 366             ($i, $subtype) = _parse_type($spec, $i+1)
 367                 or return;
 368
 369             $start = $i+1; # reset
 370
 371             push @list, $subtype;
 372         }
 373     }
 374     if($i - $start){
 375         push @list, _find_or_create_regular_type(substr $spec, $start, $i - $start);
 376     }
 377
 378     if(@list == 0){
 379        return;
 380     }
 381     elsif(@list == 1){
 382         return ($len, $list[0]);
 383     }
 384     else{
 385         return ($len, _find_or_create_union_type(@list));
 386     }
 387 }
 388
 389
 390 sub find_type_constraint {
 391     my($spec) = @_;
 392     return $spec if blessed($spec) && $spec->isa('Mouse::Meta::TypeConstraint');
 393
 394     $spec =~ s/\s+//g;
 395     return $TYPE{$spec};
 396 }
 397
 398 sub find_or_parse_type_constraint {
 399     my($spec) = @_;
 400     return $spec if blessed($spec) && $spec->isa('Mouse::Meta::TypeConstraint');
 401
 402     $spec =~ s/\s+//g;
 403     return $TYPE{$spec} || do{
 404         my($pos, $type) = _parse_type($spec, 0);
 405         $type;
 406     };
 407 }
 408
 409 sub find_or_create_does_type_constraint{
 410     my $type = find_or_parse_type_constriant(@_) || role_type(@_);
 411
 412     if($type->{type} && $type->{type} ne 'Role'){
 413         Carp::cluck("$type is not a role type");
 414     }
 415     return $type;
 416 }
 417
 418 sub find_or_create_isa_type_constraint {
 419     return find_or_parse_type_constraint(@_) || class_type(@_);
 420 }
 421
 422 1;
 423
 424 __END__
 425
 426 =head1 NAME
 427
 428 Mouse::Util::TypeConstraints - Type constraint system for Mouse
 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