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