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