lib/Mouse/Util/TypeConstraints.pm

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