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