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