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