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