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