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