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