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