lib/Mouse/Util/TypeConstraints.pm

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