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