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