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