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