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 =head1 VERSION
 418
 419 This document describes Mouse version 0.37_06
 420
 421 =head2 SYNOPSIS
 422
 423   use Mouse::Util::TypeConstraints;
 424
 425   subtype 'Natural'
 426       => as 'Int'
 427       => where { $_ > 0 };
 428
 429   subtype 'NaturalLessThanTen'
 430       => as 'Natural'
 431       => where { $_ < 10 }
 432       => message { "This number ($_) is not less than ten!" };
 433
 434   coerce 'Num'
 435       => from 'Str'
 436         => via { 0+$_ };
 437
 438   enum 'RGBColors' => qw(red green blue);
 439
 440   no Mouse::Util::TypeConstraints;
 441
 442 =head1 DESCRIPTION
 443
 444 This module provides Mouse with the ability to create custom type
 445 constraints to be used in attribute definition.
 446
 447 =head2 Important Caveat
 448
 449 This is B<NOT> a type system for Perl 5. These are type constraints,
 450 and they are not used by Mouse unless you tell it to. No type
 451 inference is performed, expressions are not typed, etc. etc. etc.
 452
 453 A type constraint is at heart a small "check if a value is valid"
 454 function. A constraint can be associated with an attribute. This
 455 simplifies parameter validation, and makes your code clearer to read,
 456 because you can refer to constraints by name.
 457
 458 =head2 Slightly Less Important Caveat
 459
 460 It is B<always> a good idea to quote your type names.
 461
 462 This prevents Perl from trying to execute the call as an indirect
 463 object call. This can be an issue when you have a subtype with the
 464 same name as a valid class.
 465
 466 For instance:
 467
 468   subtype DateTime => as Object => where { $_->isa('DateTime') };
 469
 470 will I<just work>, while this:
 471
 472   use DateTime;
 473   subtype DateTime => as Object => where { $_->isa('DateTime') };
 474
 475 will fail silently and cause many headaches. The simple way to solve
 476 this, as well as future proof your subtypes from classes which have
 477 yet to have been created, is to quote the type name:
 478
 479   use DateTime;
 480   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 481
 482 =head2 Default Type Constraints
 483
 484 This module also provides a simple hierarchy for Perl 5 types, here is
 485 that hierarchy represented visually.
 486
 487   Any
 488   Item
 489       Bool
 490       Maybe[`a]
 491       Undef
 492       Defined
 493           Value
 494               Num
 495                 Int
 496               Str
 497                 ClassName
 498                 RoleName
 499           Ref
 500               ScalarRef
 501               ArrayRef[`a]
 502               HashRef[`a]
 503               CodeRef
 504               RegexpRef
 505               GlobRef
 506                 FileHandle
 507               Object
 508
 509 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 510 parameterized, this means you can say:
 511
 512   ArrayRef[Int]    # an array of integers
 513   HashRef[CodeRef] # a hash of str to CODE ref mappings
 514   Maybe[Str]       # value may be a string, may be undefined
 515
 516 If Mouse finds a name in brackets that it does not recognize as an
 517 existing type, it assumes that this is a class name, for example
 518 C<ArrayRef[DateTime]>.
 519
 520 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 521 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 522 name, I<not> as a parameterization of C<ArrayRef>.
 523
 524 B<NOTE:> The C<Undef> type constraint for the most part works
 525 correctly now, but edge cases may still exist, please use it
 526 sparingly.
 527
 528 B<NOTE:> The C<ClassName> type constraint does a complex package
 529 existence check. This means that your class B<must> be loaded for this
 530 type constraint to pass.
 531
 532 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 533 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 534 constraint checks that an I<object does> the named role.
 535
 536 =head2 Type Constraint Naming
 537
 538 Type name declared via this module can only contain alphanumeric
 539 characters, colons (:), and periods (.).
 540
 541 Since the types created by this module are global, it is suggested
 542 that you namespace your types just as you would namespace your
 543 modules. So instead of creating a I<Color> type for your
 544 B<My::Graphics> module, you would call the type
 545 I<My::Graphics::Types::Color> instead.
 546
 547 =head2 Use with Other Constraint Modules
 548
 549 This module can play nicely with other constraint modules with some
 550 slight tweaking. The C<where> clause in types is expected to be a
 551 C<CODE> reference which checks it's first argument and returns a
 552 boolean. Since most constraint modules work in a similar way, it
 553 should be simple to adapt them to work with Mouse.
 554
 555 For instance, this is how you could use it with
 556 L<Declare::Constraints::Simple> to declare a completely new type.
 557
 558   type 'HashOfArrayOfObjects',
 559       {
 560       where => IsHashRef(
 561           -keys   => HasLength,
 562           -values => IsArrayRef(IsObject)
 563       )
 564   };
 565
 566 Here is an example of using L<Test::Deep> and it's non-test
 567 related C<eq_deeply> function.
 568
 569   type 'ArrayOfHashOfBarsAndRandomNumbers'
 570       => where {
 571           eq_deeply($_,
 572               array_each(subhashof({
 573                   bar           => isa('Bar'),
 574                   random_number => ignore()
 575               })))
 576         };
 577
 578 =head1 METHODS
 579
 580 =head2 C<< list_all_builtin_type_constraints -> (Names) >>
 581
 582 Returns the names of builtin type constraints.
 583
 584 =head2 C<< list_all_type_constraints -> (Names) >>
 585
 586 Returns the names of all the type constraints.
 587
 588 =head1 FUNCTIONS
 589
 590 =over 4
 591
 592 =item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >>
 593
 594 =item C<< subtype as 'Parent' => where { } ...  -> Mouse::Meta::TypeConstraint >>
 595
 596 =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >>
 597
 598 =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
 599
 600 =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
 601
 602 =back
 603
 604 =over 4
 605
 606 =item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >>
 607
 608 =back
 609
 610 =head1 THANKS
 611
 612 Much of this documentation was taken from C<Moose::Util::TypeConstraints>
 613
 614 =head1 SEE ALSO
 615
 616 L<Moose::Util::TypeConstraints>
 617
 618 =cut
 619
 620