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 optimize_as
  13         from via
  14         type subtype coerce class_type role_type enum
  15         find_type_constraint
  16     )],
  17 );
  18
  19 my %TYPE;
  20
  21 sub as          ($) { (as => $_[0]) }
  22 sub where       (&) { (where => $_[0]) }
  23 sub message     (&) { (message => $_[0]) }
  24 sub optimize_as (&) { (optimize_as => $_[0]) }
  25
  26 sub from    { @_ }
  27 sub via (&) { $_[0] }
  28
  29 BEGIN {
  30     my %builtins = (
  31         Any        => undef, # null check
  32         Item       => undef, # null check
  33         Maybe      => undef, # null check
  34
  35         Bool       => sub { $_[0] ? $_[0] eq '1' : 1 },
  36         Undef      => sub { !defined($_[0]) },
  37         Defined    => sub { defined($_[0]) },
  38         Value      => sub { defined($_[0]) && !ref($_[0]) },
  39         Num        => sub { !ref($_[0]) && looks_like_number($_[0]) },
  40         Int        => sub { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ },
  41         Str        => sub { defined($_[0]) && !ref($_[0]) },
  42         Ref        => sub { ref($_[0]) },
  43
  44         ScalarRef  => sub { ref($_[0]) eq 'SCALAR' },
  45         ArrayRef   => sub { ref($_[0]) eq 'ARRAY'  },
  46         HashRef    => sub { ref($_[0]) eq 'HASH'   },
  47         CodeRef    => sub { ref($_[0]) eq 'CODE'   },
  48         RegexpRef  => sub { ref($_[0]) eq 'Regexp' },
  49         GlobRef    => sub { ref($_[0]) eq 'GLOB'   },
  50
  51         FileHandle => sub {
  52             ref($_[0]) eq 'GLOB' && openhandle($_[0])
  53             or
  54             blessed($_[0]) && $_[0]->isa("IO::Handle")
  55         },
  56
  57         Object     => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' },
  58
  59         ClassName  => sub { Mouse::Util::is_class_loaded($_[0]) },
  60         RoleName   => sub { (Mouse::Util::find_meta($_[0]) || return 0)->isa('Mouse::Meta::Role') },
  61     );
  62
  63     while (my ($name, $code) = each %builtins) {
  64         $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
  65             name      => $name,
  66             optimized => $code,
  67         );
  68     }
  69
  70     sub optimized_constraints { # DEPRECATED
  71         Carp::cluck('optimized_constraints() has been deprecated');
  72         return \%TYPE;
  73     }
  74
  75     my @builtins = keys %TYPE;
  76     sub list_all_builtin_type_constraints { @builtins }
  77
  78     sub list_all_type_constraints         { keys %TYPE }
  79 }
  80
  81 sub _create_type{
  82     my $mode = shift;
  83
  84     my $name;
  85     my %args;
  86
  87     if(@_ == 1 && ref $_[0]){   # @_ : { name => $name, where => ... }
  88         %args = %{$_[0]};
  89     }
  90     elsif(@_ == 2 && ref $_[1]){ # @_ : $name => { where => ... }
  91         $name = $_[0];
  92         %args = %{$_[1]};
  93     }
  94     elsif(@_ % 2){               # @_ : $name => ( where => ... )
  95         ($name, %args) = @_;
  96     }
  97     else{                        # @_ : (name => $name, where => ...)
  98         %args = @_;
  99     }
 100
 101     if(!defined $name){
 102         if(!defined($name = $args{name})){
 103             $name = '__ANON__';
 104         }
 105     }
 106
 107     $args{name} = $name;
 108     my $parent;
 109     if($mode eq 'subtype'){
 110         $parent = delete $args{as};
 111         if(!$parent){
 112             $parent = delete $args{name};
 113             $name   = '__ANON__';
 114         }
 115     }
 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         $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 = sort{ $a cmp $b } map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
 306
 307     my $name = join '|', @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         my $type = _find_or_create_regular_type( substr $spec, $start, $i - $start );
 366
 367         if(defined $type){
 368             push @list, $type;
 369         }
 370         elsif($start != 0) {
 371             # RT #50421
 372             # create a new class type
 373             push @list, class_type( substr $spec, $start, $i - $start );
 374         }
 375     }
 376
 377     if(@list == 0){
 378        return;
 379     }
 380     elsif(@list == 1){
 381         return ($len, $list[0]);
 382     }
 383     else{
 384         return ($len, _find_or_create_union_type(@list));
 385     }
 386 }
 387
 388
 389 sub find_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};
 395 }
 396
 397 sub find_or_parse_type_constraint {
 398     my($spec) = @_;
 399     return $spec if blessed($spec) && $spec->isa('Mouse::Meta::TypeConstraint');
 400
 401     $spec =~ s/\s+//g;
 402     return $TYPE{$spec} || do{
 403         my($pos, $type) = _parse_type($spec, 0);
 404         $type;
 405     };
 406 }
 407
 408 sub find_or_create_does_type_constraint{
 409     return find_or_parse_type_constraint(@_) || role_type(@_);
 410 }
 411
 412 sub find_or_create_isa_type_constraint {
 413     return find_or_parse_type_constraint(@_) || class_type(@_);
 414 }
 415
 416 1;
 417
 418 __END__
 419
 420 =head1 NAME
 421
 422 Mouse::Util::TypeConstraints - Type constraint system for Mouse
 423
 424 =head1 VERSION
 425
 426 This document describes Mouse version 0.40
 427
 428 =head2 SYNOPSIS
 429
 430   use Mouse::Util::TypeConstraints;
 431
 432   subtype 'Natural'
 433       => as 'Int'
 434       => where { $_ > 0 };
 435
 436   subtype 'NaturalLessThanTen'
 437       => as 'Natural'
 438       => where { $_ < 10 }
 439       => message { "This number ($_) is not less than ten!" };
 440
 441   coerce 'Num'
 442       => from 'Str'
 443         => via { 0+$_ };
 444
 445   enum 'RGBColors' => qw(red green blue);
 446
 447   no Mouse::Util::TypeConstraints;
 448
 449 =head1 DESCRIPTION
 450
 451 This module provides Mouse with the ability to create custom type
 452 constraints to be used in attribute definition.
 453
 454 =head2 Important Caveat
 455
 456 This is B<NOT> a type system for Perl 5. These are type constraints,
 457 and they are not used by Mouse unless you tell it to. No type
 458 inference is performed, expressions are not typed, etc. etc. etc.
 459
 460 A type constraint is at heart a small "check if a value is valid"
 461 function. A constraint can be associated with an attribute. This
 462 simplifies parameter validation, and makes your code clearer to read,
 463 because you can refer to constraints by name.
 464
 465 =head2 Slightly Less Important Caveat
 466
 467 It is B<always> a good idea to quote your type names.
 468
 469 This prevents Perl from trying to execute the call as an indirect
 470 object call. This can be an issue when you have a subtype with the
 471 same name as a valid class.
 472
 473 For instance:
 474
 475   subtype DateTime => as Object => where { $_->isa('DateTime') };
 476
 477 will I<just work>, while this:
 478
 479   use DateTime;
 480   subtype DateTime => as Object => where { $_->isa('DateTime') };
 481
 482 will fail silently and cause many headaches. The simple way to solve
 483 this, as well as future proof your subtypes from classes which have
 484 yet to have been created, is to quote the type name:
 485
 486   use DateTime;
 487   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 488
 489 =head2 Default Type Constraints
 490
 491 This module also provides a simple hierarchy for Perl 5 types, here is
 492 that hierarchy represented visually.
 493
 494   Any
 495   Item
 496       Bool
 497       Maybe[`a]
 498       Undef
 499       Defined
 500           Value
 501               Num
 502                 Int
 503               Str
 504                 ClassName
 505                 RoleName
 506           Ref
 507               ScalarRef
 508               ArrayRef[`a]
 509               HashRef[`a]
 510               CodeRef
 511               RegexpRef
 512               GlobRef
 513                 FileHandle
 514               Object
 515
 516 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 517 parameterized, this means you can say:
 518
 519   ArrayRef[Int]    # an array of integers
 520   HashRef[CodeRef] # a hash of str to CODE ref mappings
 521   Maybe[Str]       # value may be a string, may be undefined
 522
 523 If Mouse finds a name in brackets that it does not recognize as an
 524 existing type, it assumes that this is a class name, for example
 525 C<ArrayRef[DateTime]>.
 526
 527 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 528 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 529 name, I<not> as a parameterization of C<ArrayRef>.
 530
 531 B<NOTE:> The C<Undef> type constraint for the most part works
 532 correctly now, but edge cases may still exist, please use it
 533 sparingly.
 534
 535 B<NOTE:> The C<ClassName> type constraint does a complex package
 536 existence check. This means that your class B<must> be loaded for this
 537 type constraint to pass.
 538
 539 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 540 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 541 constraint checks that an I<object does> the named role.
 542
 543 =head2 Type Constraint Naming
 544
 545 Type name declared via this module can only contain alphanumeric
 546 characters, colons (:), and periods (.).
 547
 548 Since the types created by this module are global, it is suggested
 549 that you namespace your types just as you would namespace your
 550 modules. So instead of creating a I<Color> type for your
 551 B<My::Graphics> module, you would call the type
 552 I<My::Graphics::Types::Color> instead.
 553
 554 =head2 Use with Other Constraint Modules
 555
 556 This module can play nicely with other constraint modules with some
 557 slight tweaking. The C<where> clause in types is expected to be a
 558 C<CODE> reference which checks it's first argument and returns a
 559 boolean. Since most constraint modules work in a similar way, it
 560 should be simple to adapt them to work with Mouse.
 561
 562 For instance, this is how you could use it with
 563 L<Declare::Constraints::Simple> to declare a completely new type.
 564
 565   type 'HashOfArrayOfObjects',
 566       {
 567       where => IsHashRef(
 568           -keys   => HasLength,
 569           -values => IsArrayRef(IsObject)
 570       )
 571   };
 572
 573 Here is an example of using L<Test::Deep> and it's non-test
 574 related C<eq_deeply> function.
 575
 576   type 'ArrayOfHashOfBarsAndRandomNumbers'
 577       => where {
 578           eq_deeply($_,
 579               array_each(subhashof({
 580                   bar           => isa('Bar'),
 581                   random_number => ignore()
 582               })))
 583         };
 584
 585 =head1 METHODS
 586
 587 =head2 C<< list_all_builtin_type_constraints -> (Names) >>
 588
 589 Returns the names of builtin type constraints.
 590
 591 =head2 C<< list_all_type_constraints -> (Names) >>
 592
 593 Returns the names of all the type constraints.
 594
 595 =head1 FUNCTIONS
 596
 597 =over 4
 598
 599 =item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >>
 600
 601 =item C<< subtype as 'Parent' => where { } ...  -> Mouse::Meta::TypeConstraint >>
 602
 603 =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >>
 604
 605 =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
 606
 607 =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
 608
 609 =back
 610
 611 =over 4
 612
 613 =item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >>
 614
 615 =back
 616
 617 =head1 THANKS
 618
 619 Much of this documentation was taken from C<Moose::Util::TypeConstraints>
 620
 621 =head1 SEE ALSO
 622
 623 L<Moose::Util::TypeConstraints>
 624
 625 =cut
 626
 627