lib/Mouse/Util/TypeConstraints.pm

   1 package Mouse::Util::TypeConstraints;
   2 use strict;
   3 use warnings;
   4
   5 use Exporter;
   6
   7 use Carp ();
   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 our @ISA    = qw(Exporter);
  15 our @EXPORT = qw(
  16     as where message from via type subtype coerce class_type role_type enum
  17     find_type_constraint
  18 );
  19
  20 my %TYPE;
  21 my %TYPE_SOURCE;
  22 my %COERCE;
  23 my %COERCE_KEYS;
  24
  25 sub as ($) {
  26     return(as => $_[0]);
  27 }
  28 sub where (&) {
  29     return(where => $_[0])
  30 }
  31 sub message (&) {
  32     return(message => $_[0])
  33 }
  34
  35 sub from    { @_ }
  36 sub via (&) { $_[0] }
  37
  38 BEGIN {
  39     my %builtins = (
  40         Any        => sub { 1 },
  41         Item       => sub { 1 },
  42
  43         Bool       => sub { $_[0] ? $_[0] eq '1' : 1 },
  44         Undef      => sub { !defined($_[0]) },
  45         Defined    => sub { defined($_[0]) },
  46         Value      => sub { defined($_[0]) && !ref($_[0]) },
  47         Num        => sub { !ref($_[0]) && looks_like_number($_[0]) },
  48         Int        => sub { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ },
  49         Str        => sub { defined($_[0]) && !ref($_[0]) },
  50         Ref        => sub { ref($_[0]) },
  51
  52         ScalarRef  => sub { ref($_[0]) eq 'SCALAR' },
  53         ArrayRef   => sub { ref($_[0]) eq 'ARRAY'  },
  54         HashRef    => sub { ref($_[0]) eq 'HASH'   },
  55         CodeRef    => sub { ref($_[0]) eq 'CODE'   },
  56         RegexpRef  => sub { ref($_[0]) eq 'Regexp' },
  57         GlobRef    => sub { ref($_[0]) eq 'GLOB'   },
  58
  59         FileHandle => sub {
  60             ref($_[0]) eq 'GLOB' && openhandle($_[0])
  61             or
  62             blessed($_[0]) && $_[0]->isa("IO::Handle")
  63         },
  64
  65         Object     => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' },
  66
  67         ClassName  => sub { Mouse::Util::is_class_loaded($_[0]) },
  68         RoleName   => sub { (Mouse::Util::find_meta($_[0]) || return 0)->isa('Mouse::Meta::Role') },
  69     );
  70
  71     while (my ($name, $code) = each %builtins) {
  72         $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
  73             name                      => $name,
  74             _compiled_type_constraint => $code,
  75         );
  76         $TYPE_SOURCE{$name} = __PACKAGE__;
  77     }
  78
  79     sub optimized_constraints { \%TYPE }
  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 type {
  88     my $name;
  89     my %conf;
  90
  91     if(@_ == 1 && ref $_[0]){ # type { where => ... }
  92         %conf = %{$_[0]};
  93     }
  94     elsif(@_ == 2 && ref $_[1]){ # type $name => { where => ... }*
  95         $name = $_[0];
  96         %conf = %{$_[1]};
  97     }
  98     elsif(@_ % 2){ # odd number of arguments
  99         $name = shift;
 100         %conf = @_;
 101     }
 102     else{
 103         %conf = @_;
 104     }
 105
 106     $name = '__ANON__' if !defined $name;
 107
 108     my $pkg = caller;
 109
 110     if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
 111         Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
 112     }
 113
 114     my $constraint = $conf{where} || do {
 115         my $as = delete $conf{as} || 'Any';
 116         ($TYPE{$as} ||= _build_type_constraint($as))->{_compiled_type_constraint};
 117     };
 118
 119     my $tc = Mouse::Meta::TypeConstraint->new(
 120         name                      => $name,
 121         _compiled_type_constraint => sub {
 122             local $_ = $_[0];
 123             return &{$constraint};
 124         },
 125     );
 126
 127     $TYPE_SOURCE{$name} = $pkg;
 128     $TYPE{$name}        = $tc;
 129
 130     return $tc;
 131 }
 132
 133 sub subtype {
 134     my $name;
 135     my %conf;
 136
 137     if(@_ == 1 && ref $_[0]){ # type { where => ... }
 138         %conf = %{$_[0]};
 139     }
 140     elsif(@_ == 2 && ref $_[1]){ # type $name => { where => ... }*
 141         $name = $_[0];
 142         %conf = %{$_[1]};
 143     }
 144     elsif(@_ % 2){ # odd number of arguments
 145         $name = shift;
 146         %conf = @_;
 147     }
 148     else{
 149         %conf = @_;
 150     }
 151
 152     $name = '__ANON__' if !defined $name;
 153
 154     my $pkg = caller($conf{_caller_level} || 1);
 155
 156     if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
 157         Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
 158     }
 159
 160     my $constraint    = delete $conf{where};
 161     my $as_constraint = find_or_create_isa_type_constraint(delete $conf{as} || 'Any')
 162         ->{_compiled_type_constraint};
 163
 164     my $tc = Mouse::Meta::TypeConstraint->new(
 165         name => $name,
 166         _compiled_type_constraint => (
 167             $constraint ?
 168             sub {
 169                 local $_ = $_[0];
 170                 $as_constraint->($_[0]) && $constraint->($_[0])
 171             } :
 172             sub {
 173                 local $_ = $_[0];
 174                 $as_constraint->($_[0]);
 175             }
 176         ),
 177         %conf,
 178     );
 179
 180     $TYPE_SOURCE{$name} = $pkg;
 181     $TYPE{$name}        = $tc;
 182
 183     return $tc;
 184 }
 185
 186 sub coerce {
 187     my $name = shift;
 188
 189     Carp::croak "Cannot find type '$name', perhaps you forgot to load it."
 190         unless $TYPE{$name};
 191
 192     unless ($COERCE{$name}) {
 193         $COERCE{$name}      = {};
 194         $COERCE_KEYS{$name} = [];
 195     }
 196
 197     while (my($type, $code) = splice @_, 0, 2) {
 198         Carp::croak "A coercion action already exists for '$type'"
 199             if $COERCE{$name}->{$type};
 200
 201         if (! $TYPE{$type}) {
 202             # looks parameterized
 203             if ($type =~ /^[^\[]+\[.+\]$/) {
 204                 $TYPE{$type} = _build_type_constraint($type);
 205             } else {
 206                 Carp::croak "Could not find the type constraint ($type) to coerce from"
 207             }
 208         }
 209
 210         push @{ $COERCE_KEYS{$name} }, $type;
 211         $COERCE{$name}->{$type} = $code;
 212     }
 213     return;
 214 }
 215
 216 sub class_type {
 217     my($name, $conf) = @_;
 218     if ($conf && $conf->{class}) {
 219         # No, you're using this wrong
 220         warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?";
 221         subtype $name => (
 222             as => $conf->{class},
 223             caller_level => (($conf->{_caller_level}||0) + 1),
 224         );
 225     }
 226     else {
 227         subtype $name => (
 228             where => sub { blessed($_) && $_->isa($name) },
 229             caller_level => (($conf->{_caller_level}||0) + 1),
 230         );
 231     }
 232 }
 233
 234 sub role_type {
 235     my($name, $conf) = @_;
 236     my $role = $conf->{role};
 237     subtype $name => (
 238         where => sub { does_role($_, $role) },
 239         caller_level => (($conf->{_caller_level}||0) + 1),
 240     );
 241 }
 242
 243 # this is an original method for Mouse
 244 sub typecast_constraints {
 245     my($class, $pkg, $types, $value) = @_;
 246     Carp::croak("wrong arguments count") unless @_ == 4;
 247
 248     local $_;
 249     for my $type ( split /\|/, $types ) {
 250         next unless $COERCE{$type};
 251         for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
 252             $_ = $value;
 253             next unless $TYPE{$coerce_type}->check($value);
 254             $_ = $value;
 255             $_ = $COERCE{$type}->{$coerce_type}->($value);
 256             return $_ if $types->check($_);
 257         }
 258     }
 259     return $value;
 260 }
 261
 262 my $serial_enum = 0;
 263 sub enum {
 264     # enum ['small', 'medium', 'large']
 265     if (ref($_[0]) eq 'ARRAY') {
 266         my @elements = @{ shift @_ };
 267
 268         my $name = 'Mouse::Util::TypeConstaints::Enum::Serial::'
 269                  . ++$serial_enum;
 270         enum($name, @elements);
 271         return $name;
 272     }
 273
 274     # enum size => 'small', 'medium', 'large'
 275     my $name = shift;
 276     my %is_valid = map { $_ => 1 } @_;
 277
 278     subtype $name => (
 279         where => sub { $is_valid{$_} },
 280         _caller_level => 1,
 281     );
 282 }
 283
 284 sub _build_type_constraint {
 285     my($spec) = @_;
 286
 287     my $code;
 288     $spec =~ s/\s+//g;
 289
 290     if ($spec =~ /\A (\w+) \[ (.+) \] \z/xms) {
 291         # parameterized
 292         my $constraint = $1;
 293         my $param      = $2;
 294         my $parent;
 295
 296         if ($constraint eq 'Maybe') {
 297             $parent = _build_type_constraint('Undef');
 298         }
 299         else {
 300             $parent = _build_type_constraint($constraint);
 301         }
 302         my $child = _build_type_constraint($param);
 303         if ($constraint eq 'ArrayRef') {
 304             my $code_str =
 305                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 306                 "sub {\n" .
 307                 "    if (\$parent->check(\$_[0])) {\n" .
 308                 "        foreach my \$e (\@{\$_[0]}) {\n" .
 309                 "            return () unless \$child->check(\$e);\n" .
 310                 "        }\n" .
 311                 "        return 1;\n" .
 312                 "    }\n" .
 313                 "    return ();\n" .
 314                 "};\n"
 315             ;
 316             $code = eval $code_str or Carp::confess("Failed to generate inline type constraint: $@");
 317         } elsif ($constraint eq 'HashRef') {
 318             my $code_str =
 319                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 320                 "sub {\n" .
 321                 "    if (\$parent->check(\$_[0])) {\n" .
 322                 "        foreach my \$e (values \%{\$_[0]}) {\n" .
 323                 "            return () unless \$child->check(\$e);\n" .
 324                 "        }\n" .
 325                 "        return 1;\n" .
 326                 "    }\n" .
 327                 "    return ();\n" .
 328                 "};\n"
 329             ;
 330             $code = eval $code_str or Carp::confess($@);
 331         } elsif ($constraint eq 'Maybe') {
 332             my $code_str =
 333                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 334                 "sub {\n" .
 335                 "    return \$child->check(\$_[0]) || \$parent->check(\$_[0]);\n" .
 336                 "};\n"
 337             ;
 338             $code = eval $code_str or Carp::confess($@);
 339         } else {
 340             Carp::confess("Support for parameterized types other than Maybe, ArrayRef or HashRef is not implemented yet");
 341         }
 342         $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
 343     } else {
 344         $code = $TYPE{ $spec };
 345         if (! $code) {
 346             # is $spec a known role?  If so, constrain with 'does' instead of 'isa'
 347             require Mouse::Meta::Role;
 348             my $check = Mouse::Meta::Role->_metaclass_cache($spec)?
 349                 'does' : 'isa';
 350             my $code_str =
 351                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 352                 "sub {\n" .
 353                 "    Scalar::Util::blessed(\$_[0]) && \$_[0]->$check('$spec');\n" .
 354                 "}"
 355             ;
 356             $code = eval $code_str  or Carp::confess($@);
 357             $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
 358         }
 359     }
 360     return Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
 361 }
 362
 363 sub find_type_constraint {
 364     my($type) = @_;
 365     if(blessed($type) && $type->isa('Mouse::Meta::TypeConstraint')){
 366         return $type;
 367     }
 368     else{
 369         return $TYPE{$type};
 370     }
 371 }
 372
 373 sub find_or_create_does_type_constraint{
 374     not_supported;
 375 }
 376
 377 sub find_or_create_isa_type_constraint {
 378     my $type_constraint = shift;
 379
 380     Carp::confess("Got isa => type_constraints, but Mouse does not yet support parameterized types for containers other than ArrayRef and HashRef and Maybe (rt.cpan.org #39795)")
 381         if $type_constraint =~ /\A ( [^\[]+ ) \[\.+\] \z/xms &&
 382            $1 ne 'ArrayRef' &&
 383            $1 ne 'HashRef'  &&
 384            $1 ne 'Maybe'
 385     ;
 386
 387
 388     $type_constraint =~ s/\s+//g;
 389
 390     my $tc =  find_type_constraint($type_constraint);
 391     if (!$tc) {
 392         my @type_constraints = split /\|/, $type_constraint;
 393         if (@type_constraints == 1) {
 394             $tc = $TYPE{$type_constraints[0]} ||
 395                 _build_type_constraint($type_constraints[0]);
 396         }
 397         else {
 398             my @code_list = map {
 399                 $TYPE{$_} || _build_type_constraint($_)
 400             } @type_constraints;
 401
 402             $tc = Mouse::Meta::TypeConstraint->new(
 403                 name => $type_constraint,
 404
 405                 _compiled_type_constraint => sub {
 406                     foreach my $code (@code_list) {
 407                         return 1 if $code->check($_[0]);
 408                     }
 409                     return 0;
 410                 },
 411             );
 412         }
 413     }
 414     return $tc;
 415 }
 416
 417 1;
 418
 419 __END__
 420
 421 =head1 NAME
 422
 423 Mouse::Util::TypeConstraints - Type constraint system for Mouse
 424
 425 =head2 SYNOPSIS
 426
 427   use Mouse::Util::TypeConstraints;
 428
 429   subtype 'Natural'
 430       => as 'Int'
 431       => where { $_ > 0 };
 432
 433   subtype 'NaturalLessThanTen'
 434       => as 'Natural'
 435       => where { $_ < 10 }
 436       => message { "This number ($_) is not less than ten!" };
 437
 438   coerce 'Num'
 439       => from 'Str'
 440         => via { 0+$_ };
 441
 442   enum 'RGBColors' => qw(red green blue);
 443
 444   no Mouse::Util::TypeConstraints;
 445
 446 =head1 DESCRIPTION
 447
 448 This module provides Mouse with the ability to create custom type
 449 constraints to be used in attribute definition.
 450
 451 =head2 Important Caveat
 452
 453 This is B<NOT> a type system for Perl 5. These are type constraints,
 454 and they are not used by Mouse unless you tell it to. No type
 455 inference is performed, expressions are not typed, etc. etc. etc.
 456
 457 A type constraint is at heart a small "check if a value is valid"
 458 function. A constraint can be associated with an attribute. This
 459 simplifies parameter validation, and makes your code clearer to read,
 460 because you can refer to constraints by name.
 461
 462 =head2 Slightly Less Important Caveat
 463
 464 It is B<always> a good idea to quote your type names.
 465
 466 This prevents Perl from trying to execute the call as an indirect
 467 object call. This can be an issue when you have a subtype with the
 468 same name as a valid class.
 469
 470 For instance:
 471
 472   subtype DateTime => as Object => where { $_->isa('DateTime') };
 473
 474 will I<just work>, while this:
 475
 476   use DateTime;
 477   subtype DateTime => as Object => where { $_->isa('DateTime') };
 478
 479 will fail silently and cause many headaches. The simple way to solve
 480 this, as well as future proof your subtypes from classes which have
 481 yet to have been created, is to quote the type name:
 482
 483   use DateTime;
 484   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 485
 486 =head2 Default Type Constraints
 487
 488 This module also provides a simple hierarchy for Perl 5 types, here is
 489 that hierarchy represented visually.
 490
 491   Any
 492   Item
 493       Bool
 494       Maybe[`a]
 495       Undef
 496       Defined
 497           Value
 498               Num
 499                 Int
 500               Str
 501                 ClassName
 502                 RoleName
 503           Ref
 504               ScalarRef
 505               ArrayRef[`a]
 506               HashRef[`a]
 507               CodeRef
 508               RegexpRef
 509               GlobRef
 510                 FileHandle
 511               Object
 512                 Role
 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 optimized_constraints -> HashRef[CODE]
 586
 587 Returns the simple type constraints that Mouse understands.
 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