lib/Mouse/Util/TypeConstraints.pm

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