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;
 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 => (as => $conf->{class});
 222     }
 223     else {
 224         subtype $name => (
 225             where => sub { blessed($_) && $_->isa($name) },
 226         );
 227     }
 228 }
 229
 230 sub role_type {
 231     my($name, $conf) = @_;
 232     my $role = $conf->{role};
 233     subtype $name => (
 234         where => sub { does_role($_, $role) },
 235     );
 236 }
 237
 238 # this is an original method for Mouse
 239 sub typecast_constraints {
 240     my($class, $pkg, $types, $value) = @_;
 241     Carp::croak("wrong arguments count") unless @_ == 4;
 242
 243     local $_;
 244     for my $type ( split /\|/, $types ) {
 245         next unless $COERCE{$type};
 246         for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
 247             $_ = $value;
 248             next unless $TYPE{$coerce_type}->check($value);
 249             $_ = $value;
 250             $_ = $COERCE{$type}->{$coerce_type}->($value);
 251             return $_ if $types->check($_);
 252         }
 253     }
 254     return $value;
 255 }
 256
 257 my $serial_enum = 0;
 258 sub enum {
 259     # enum ['small', 'medium', 'large']
 260     if (ref($_[0]) eq 'ARRAY') {
 261         my @elements = @{ shift @_ };
 262
 263         my $name = 'Mouse::Util::TypeConstaints::Enum::Serial::'
 264                  . ++$serial_enum;
 265         enum($name, @elements);
 266         return $name;
 267     }
 268
 269     # enum size => 'small', 'medium', 'large'
 270     my $name = shift;
 271     my %is_valid = map { $_ => 1 } @_;
 272
 273     subtype(
 274         $name => where => sub { $is_valid{$_} }
 275     );
 276 }
 277
 278 sub _build_type_constraint {
 279     my($spec) = @_;
 280
 281     my $code;
 282     $spec =~ s/\s+//g;
 283
 284     if ($spec =~ /\A (\w+) \[ (.+) \] \z/xms) {
 285         # parameterized
 286         my $constraint = $1;
 287         my $param      = $2;
 288         my $parent;
 289
 290         if ($constraint eq 'Maybe') {
 291             $parent = _build_type_constraint('Undef');
 292         }
 293         else {
 294             $parent = _build_type_constraint($constraint);
 295         }
 296         my $child = _build_type_constraint($param);
 297         if ($constraint eq 'ArrayRef') {
 298             my $code_str =
 299                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 300                 "sub {\n" .
 301                 "    if (\$parent->check(\$_[0])) {\n" .
 302                 "        foreach my \$e (\@{\$_[0]}) {\n" .
 303                 "            return () unless \$child->check(\$e);\n" .
 304                 "        }\n" .
 305                 "        return 1;\n" .
 306                 "    }\n" .
 307                 "    return ();\n" .
 308                 "};\n"
 309             ;
 310             $code = eval $code_str or Carp::confess("Failed to generate inline type constraint: $@");
 311         } elsif ($constraint eq 'HashRef') {
 312             my $code_str =
 313                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 314                 "sub {\n" .
 315                 "    if (\$parent->check(\$_[0])) {\n" .
 316                 "        foreach my \$e (values \%{\$_[0]}) {\n" .
 317                 "            return () unless \$child->check(\$e);\n" .
 318                 "        }\n" .
 319                 "        return 1;\n" .
 320                 "    }\n" .
 321                 "    return ();\n" .
 322                 "};\n"
 323             ;
 324             $code = eval $code_str or Carp::confess($@);
 325         } elsif ($constraint eq 'Maybe') {
 326             my $code_str =
 327                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 328                 "sub {\n" .
 329                 "    return \$child->check(\$_[0]) || \$parent->check(\$_[0]);\n" .
 330                 "};\n"
 331             ;
 332             $code = eval $code_str or Carp::confess($@);
 333         } else {
 334             Carp::confess("Support for parameterized types other than Maybe, ArrayRef or HashRef is not implemented yet");
 335         }
 336         $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
 337     } else {
 338         $code = $TYPE{ $spec };
 339         if (! $code) {
 340             # is $spec a known role?  If so, constrain with 'does' instead of 'isa'
 341             require Mouse::Meta::Role;
 342             my $check = Mouse::Meta::Role->_metaclass_cache($spec)?
 343                 'does' : 'isa';
 344             my $code_str =
 345                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 346                 "sub {\n" .
 347                 "    Scalar::Util::blessed(\$_[0]) && \$_[0]->$check('$spec');\n" .
 348                 "}"
 349             ;
 350             $code = eval $code_str  or Carp::confess($@);
 351             $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
 352         }
 353     }
 354     return Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
 355 }
 356
 357 sub find_type_constraint {
 358     my($type) = @_;
 359     if(blessed($type) && $type->isa('Mouse::Meta::TypeConstraint')){
 360         return $type;
 361     }
 362     else{
 363         return $TYPE{$type};
 364     }
 365 }
 366
 367 sub find_or_create_does_type_constraint{
 368     not_supported;
 369 }
 370
 371 sub find_or_create_isa_type_constraint {
 372     my $type_constraint = shift;
 373
 374     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)")
 375         if $type_constraint =~ /\A ( [^\[]+ ) \[\.+\] \z/xms &&
 376            $1 ne 'ArrayRef' &&
 377            $1 ne 'HashRef'  &&
 378            $1 ne 'Maybe'
 379     ;
 380
 381
 382     $type_constraint =~ s/\s+//g;
 383
 384     my $tc =  find_type_constraint($type_constraint);
 385     if (!$tc) {
 386         my @type_constraints = split /\|/, $type_constraint;
 387         if (@type_constraints == 1) {
 388             $tc = $TYPE{$type_constraints[0]} ||
 389                 _build_type_constraint($type_constraints[0]);
 390         }
 391         else {
 392             my @code_list = map {
 393                 $TYPE{$_} || _build_type_constraint($_)
 394             } @type_constraints;
 395
 396             $tc = Mouse::Meta::TypeConstraint->new(
 397                 name => $type_constraint,
 398
 399                 _compiled_type_constraint => sub {
 400                     foreach my $code (@code_list) {
 401                         return 1 if $code->check($_[0]);
 402                     }
 403                     return 0;
 404                 },
 405             );
 406         }
 407     }
 408     return $tc;
 409 }
 410
 411 1;
 412
 413 __END__
 414
 415 =head1 NAME
 416
 417 Mouse::Util::TypeConstraints - Type constraint system for Mouse
 418
 419 =head2 SYNOPSIS
 420
 421   use Mouse::Util::TypeConstraints;
 422
 423   subtype 'Natural'
 424       => as 'Int'
 425       => where { $_ > 0 };
 426
 427   subtype 'NaturalLessThanTen'
 428       => as 'Natural'
 429       => where { $_ < 10 }
 430       => message { "This number ($_) is not less than ten!" };
 431
 432   coerce 'Num'
 433       => from 'Str'
 434         => via { 0+$_ };
 435
 436   enum 'RGBColors' => qw(red green blue);
 437
 438   no Mouse::Util::TypeConstraints;
 439
 440 =head1 DESCRIPTION
 441
 442 This module provides Mouse with the ability to create custom type
 443 constraints to be used in attribute definition.
 444
 445 =head2 Important Caveat
 446
 447 This is B<NOT> a type system for Perl 5. These are type constraints,
 448 and they are not used by Mouse unless you tell it to. No type
 449 inference is performed, expressions are not typed, etc. etc. etc.
 450
 451 A type constraint is at heart a small "check if a value is valid"
 452 function. A constraint can be associated with an attribute. This
 453 simplifies parameter validation, and makes your code clearer to read,
 454 because you can refer to constraints by name.
 455
 456 =head2 Slightly Less Important Caveat
 457
 458 It is B<always> a good idea to quote your type names.
 459
 460 This prevents Perl from trying to execute the call as an indirect
 461 object call. This can be an issue when you have a subtype with the
 462 same name as a valid class.
 463
 464 For instance:
 465
 466   subtype DateTime => as Object => where { $_->isa('DateTime') };
 467
 468 will I<just work>, while this:
 469
 470   use DateTime;
 471   subtype DateTime => as Object => where { $_->isa('DateTime') };
 472
 473 will fail silently and cause many headaches. The simple way to solve
 474 this, as well as future proof your subtypes from classes which have
 475 yet to have been created, is to quote the type name:
 476
 477   use DateTime;
 478   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 479
 480 =head2 Default Type Constraints
 481
 482 This module also provides a simple hierarchy for Perl 5 types, here is
 483 that hierarchy represented visually.
 484
 485   Any
 486   Item
 487       Bool
 488       Maybe[`a]
 489       Undef
 490       Defined
 491           Value
 492               Num
 493                 Int
 494               Str
 495                 ClassName
 496                 RoleName
 497           Ref
 498               ScalarRef
 499               ArrayRef[`a]
 500               HashRef[`a]
 501               CodeRef
 502               RegexpRef
 503               GlobRef
 504                 FileHandle
 505               Object
 506                 Role
 507
 508 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 509 parameterized, this means you can say:
 510
 511   ArrayRef[Int]    # an array of integers
 512   HashRef[CodeRef] # a hash of str to CODE ref mappings
 513   Maybe[Str]       # value may be a string, may be undefined
 514
 515 If Mouse finds a name in brackets that it does not recognize as an
 516 existing type, it assumes that this is a class name, for example
 517 C<ArrayRef[DateTime]>.
 518
 519 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 520 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 521 name, I<not> as a parameterization of C<ArrayRef>.
 522
 523 B<NOTE:> The C<Undef> type constraint for the most part works
 524 correctly now, but edge cases may still exist, please use it
 525 sparingly.
 526
 527 B<NOTE:> The C<ClassName> type constraint does a complex package
 528 existence check. This means that your class B<must> be loaded for this
 529 type constraint to pass.
 530
 531 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 532 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 533 constraint checks that an I<object does> the named role.
 534
 535 =head2 Type Constraint Naming
 536
 537 Type name declared via this module can only contain alphanumeric
 538 characters, colons (:), and periods (.).
 539
 540 Since the types created by this module are global, it is suggested
 541 that you namespace your types just as you would namespace your
 542 modules. So instead of creating a I<Color> type for your
 543 B<My::Graphics> module, you would call the type
 544 I<My::Graphics::Types::Color> instead.
 545
 546 =head2 Use with Other Constraint Modules
 547
 548 This module can play nicely with other constraint modules with some
 549 slight tweaking. The C<where> clause in types is expected to be a
 550 C<CODE> reference which checks it's first argument and returns a
 551 boolean. Since most constraint modules work in a similar way, it
 552 should be simple to adapt them to work with Mouse.
 553
 554 For instance, this is how you could use it with
 555 L<Declare::Constraints::Simple> to declare a completely new type.
 556
 557   type 'HashOfArrayOfObjects',
 558       {
 559       where => IsHashRef(
 560           -keys   => HasLength,
 561           -values => IsArrayRef(IsObject)
 562       )
 563   };
 564
 565 Here is an example of using L<Test::Deep> and it's non-test
 566 related C<eq_deeply> function.
 567
 568   type 'ArrayOfHashOfBarsAndRandomNumbers'
 569       => where {
 570           eq_deeply($_,
 571               array_each(subhashof({
 572                   bar           => isa('Bar'),
 573                   random_number => ignore()
 574               })))
 575         };
 576
 577 =head1 METHODS
 578
 579 =head2 optimized_constraints -> HashRef[CODE]
 580
 581 Returns the simple type constraints that Mouse understands.
 582
 583 =head1 FUNCTIONS
 584
 585 =over 4
 586
 587 =item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >>
 588
 589 =item C<< subtype as 'Parent' => where { } ...  -> Mouse::Meta::TypeConstraint >>
 590
 591 =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >>
 592
 593 =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >>
 594
 595 =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >>
 596
 597 =back
 598
 599 =over 4
 600
 601 =item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >>
 602
 603 =back
 604
 605 =head1 THANKS
 606
 607 Much of this documentation was taken from C<Moose::Util::TypeConstraints>
 608
 609 =head1 SEE ALSO
 610
 611 L<Moose::Util::TypeConstraints>
 612
 613 =cut
 614
 615