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
 346 __END__
 347
 348 =head1 NAME
 349
 350 Mouse::Util::TypeConstraints - Type constraint system for Mouse
 351
 352 =head1 VERSION
 353
 354 This document describes Mouse version 0.40_04
 355
 356 =head2 SYNOPSIS
 357
 358   use Mouse::Util::TypeConstraints;
 359
 360   subtype 'Natural'
 361       => as 'Int'
 362       => where { $_ > 0 };
 363
 364   subtype 'NaturalLessThanTen'
 365       => as 'Natural'
 366       => where { $_ < 10 }
 367       => message { "This number ($_) is not less than ten!" };
 368
 369   coerce 'Num'
 370       => from 'Str'
 371         => via { 0+$_ };
 372
 373   enum 'RGBColors' => qw(red green blue);
 374
 375   no Mouse::Util::TypeConstraints;
 376
 377 =head1 DESCRIPTION
 378
 379 This module provides Mouse with the ability to create custom type
 380 constraints to be used in attribute definition.
 381
 382 =head2 Important Caveat
 383
 384 This is B<NOT> a type system for Perl 5. These are type constraints,
 385 and they are not used by Mouse unless you tell it to. No type
 386 inference is performed, expressions are not typed, etc. etc. etc.
 387
 388 A type constraint is at heart a small "check if a value is valid"
 389 function. A constraint can be associated with an attribute. This
 390 simplifies parameter validation, and makes your code clearer to read,
 391 because you can refer to constraints by name.
 392
 393 =head2 Slightly Less Important Caveat
 394
 395 It is B<always> a good idea to quote your type names.
 396
 397 This prevents Perl from trying to execute the call as an indirect
 398 object call. This can be an issue when you have a subtype with the
 399 same name as a valid class.
 400
 401 For instance:
 402
 403   subtype DateTime => as Object => where { $_->isa('DateTime') };
 404
 405 will I<just work>, while this:
 406
 407   use DateTime;
 408   subtype DateTime => as Object => where { $_->isa('DateTime') };
 409
 410 will fail silently and cause many headaches. The simple way to solve
 411 this, as well as future proof your subtypes from classes which have
 412 yet to have been created, is to quote the type name:
 413
 414   use DateTime;
 415   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 416
 417 =head2 Default Type Constraints
 418
 419 This module also provides a simple hierarchy for Perl 5 types, here is
 420 that hierarchy represented visually.
 421
 422   Any
 423   Item
 424       Bool
 425       Maybe[`a]
 426       Undef
 427       Defined
 428           Value
 429               Num
 430                 Int
 431               Str
 432                 ClassName
 433                 RoleName
 434           Ref
 435               ScalarRef
 436               ArrayRef[`a]
 437               HashRef[`a]
 438               CodeRef
 439               RegexpRef
 440               GlobRef
 441                 FileHandle
 442               Object
 443
 444 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 445 parameterized, this means you can say:
 446
 447   ArrayRef[Int]    # an array of integers
 448   HashRef[CodeRef] # a hash of str to CODE ref mappings
 449   Maybe[Str]       # value may be a string, may be undefined
 450
 451 If Mouse finds a name in brackets that it does not recognize as an
 452 existing type, it assumes that this is a class name, for example
 453 C<ArrayRef[DateTime]>.
 454
 455 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 456 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 457 name, I<not> as a parameterization of C<ArrayRef>.
 458
 459 B<NOTE:> The C<Undef> type constraint for the most part works
 460 correctly now, but edge cases may still exist, please use it
 461 sparingly.
 462
 463 B<NOTE:> The C<ClassName> type constraint does a complex package
 464 existence check. This means that your class B<must> be loaded for this
 465 type constraint to pass.
 466
 467 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 468 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 469 constraint checks that an I<object does> the named role.
 470
 471 =head2 Type Constraint Naming
 472
 473 Type name declared via this module can only contain alphanumeric
 474 characters, colons (:), and periods (.).
 475
 476 Since the types created by this module are global, it is suggested
 477 that you namespace your types just as you would namespace your
 478 modules. So instead of creating a I<Color> type for your
 479 B<My::Graphics> module, you would call the type
 480 I<My::Graphics::Types::Color> instead.
 481
 482 =head2 Use with Other Constraint Modules
 483
 484 This module can play nicely with other constraint modules with some
 485 slight tweaking. The C<where> clause in types is expected to be a
 486 C<CODE> reference which checks it's first argument and returns a
 487 boolean. Since most constraint modules work in a similar way, it
 488 should be simple to adapt them to work with Mouse.
 489
 490 For instance, this is how you could use it with
 491 L<Declare::Constraints::Simple> to declare a completely new type.
 492
 493   type 'HashOfArrayOfObjects',
 494       {
 495       where => IsHashRef(
 496           -keys   => HasLength,
 497           -values => IsArrayRef(IsObject)
 498       )
 499   };
 500
 501 Here is an example of using L<Test::Deep> and it's non-test
 502 related C<eq_deeply> function.
 503
 504   type 'ArrayOfHashOfBarsAndRandomNumbers'
 505       => where {
 506           eq_deeply($_,
 507               array_each(subhashof({
 508                   bar           => isa('Bar'),
 509                   random_number => ignore()
 510               })))
 511         };
 512
 513 =head1 METHODS
 514
 515 =head2 C<< list_all_builtin_type_constraints -> (Names) >>
 516
 517 Returns the names of builtin type constraints.
 518
 519 =head2 C<< list_all_type_constraints -> (Names) >>
 520
 521 Returns the names of all the type constraints.
 522
 523 =head1 FUNCTIONS
 524
 525 =over 4
 526
 527 =item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >>
 528
 529 =item C<< subtype as 'Parent' => where { } ...  -> Mouse::Meta::TypeConstraint >>
 530
 531 =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >>
 532
 533 =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
 534
 535 =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
 536
 537 =back
 538
 539 =over 4
 540
 541 =item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >>
 542
 543 =back
 544
 545 =head1 THANKS
 546
 547 Much of this documentation was taken from C<Moose::Util::TypeConstraints>
 548
 549 =head1 SEE ALSO
 550
 551 L<Moose::Util::TypeConstraints>
 552
 553 =cut
 554
 555