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     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)")
 312         if $type_constraint =~ /\A ( [^\[]+ ) \[\.+\] \z/xms &&
 313            $1 ne 'ArrayRef' &&
 314            $1 ne 'HashRef'  &&
 315            $1 ne 'Maybe'
 316     ;
 317
 318     my $code;
 319
 320     $type_constraint =~ s/\s+//g;
 321
 322     $code = $TYPE{$type_constraint};
 323     if (! $code) {
 324         my @type_constraints = split /\|/, $type_constraint;
 325         if (@type_constraints == 1) {
 326             $code = $TYPE{$type_constraints[0]} ||
 327                 _build_type_constraint($type_constraints[0]);
 328         } else {
 329             my @code_list = map {
 330                 $TYPE{$_} || _build_type_constraint($_)
 331             } @type_constraints;
 332             $code = Mouse::Meta::TypeConstraint->new(
 333                 _compiled_type_constraint => sub {
 334                     my $i = 0;
 335                     for my $code (@code_list) {
 336                         return 1 if $code->check($_[0]);
 337                     }
 338                     return 0;
 339                 },
 340                 name => $type_constraint,
 341             );
 342         }
 343     }
 344     return $code;
 345 }
 346
 347 1;
 348
 349 __END__
 350
 351 =head1 NAME
 352
 353 Mouse::Util::TypeConstraints - Type constraint system for Mouse
 354
 355 =head2 SYNOPSIS
 356
 357   use Mouse::Util::TypeConstraints;
 358
 359   subtype 'Natural'
 360       => as 'Int'
 361       => where { $_ > 0 };
 362
 363   subtype 'NaturalLessThanTen'
 364       => as 'Natural'
 365       => where { $_ < 10 }
 366       => message { "This number ($_) is not less than ten!" };
 367
 368   coerce 'Num'
 369       => from 'Str'
 370         => via { 0+$_ };
 371
 372   enum 'RGBColors' => qw(red green blue);
 373
 374   no Mouse::Util::TypeConstraints;
 375
 376 =head1 DESCRIPTION
 377
 378 This module provides Mouse with the ability to create custom type
 379 constraints to be used in attribute definition.
 380
 381 =head2 Important Caveat
 382
 383 This is B<NOT> a type system for Perl 5. These are type constraints,
 384 and they are not used by Mouse unless you tell it to. No type
 385 inference is performed, expressions are not typed, etc. etc. etc.
 386
 387 A type constraint is at heart a small "check if a value is valid"
 388 function. A constraint can be associated with an attribute. This
 389 simplifies parameter validation, and makes your code clearer to read,
 390 because you can refer to constraints by name.
 391
 392 =head2 Slightly Less Important Caveat
 393
 394 It is B<always> a good idea to quote your type names.
 395
 396 This prevents Perl from trying to execute the call as an indirect
 397 object call. This can be an issue when you have a subtype with the
 398 same name as a valid class.
 399
 400 For instance:
 401
 402   subtype DateTime => as Object => where { $_->isa('DateTime') };
 403
 404 will I<just work>, while this:
 405
 406   use DateTime;
 407   subtype DateTime => as Object => where { $_->isa('DateTime') };
 408
 409 will fail silently and cause many headaches. The simple way to solve
 410 this, as well as future proof your subtypes from classes which have
 411 yet to have been created, is to quote the type name:
 412
 413   use DateTime;
 414   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 415
 416 =head2 Default Type Constraints
 417
 418 This module also provides a simple hierarchy for Perl 5 types, here is
 419 that hierarchy represented visually.
 420
 421   Any
 422   Item
 423       Bool
 424       Maybe[`a]
 425       Undef
 426       Defined
 427           Value
 428               Num
 429                 Int
 430               Str
 431                 ClassName
 432                 RoleName
 433           Ref
 434               ScalarRef
 435               ArrayRef[`a]
 436               HashRef[`a]
 437               CodeRef
 438               RegexpRef
 439               GlobRef
 440                 FileHandle
 441               Object
 442                 Role
 443
 444 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 445 parameterized, this means you can say:
 446
 447   ArrayRef[Int]    # an array of integers
 448   HashRef[CodeRef] # a hash of str to CODE ref mappings
 449   Maybe[Str]       # value may be a string, may be undefined
 450
 451 If Mouse finds a name in brackets that it does not recognize as an
 452 existing type, it assumes that this is a class name, for example
 453 C<ArrayRef[DateTime]>.
 454
 455 B<NOTE:> Unless you parameterize a type, then it is invalid to include
 456 the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
 457 name, I<not> as a parameterization of C<ArrayRef>.
 458
 459 B<NOTE:> The C<Undef> type constraint for the most part works
 460 correctly now, but edge cases may still exist, please use it
 461 sparingly.
 462
 463 B<NOTE:> The C<ClassName> type constraint does a complex package
 464 existence check. This means that your class B<must> be loaded for this
 465 type constraint to pass.
 466
 467 B<NOTE:> The C<RoleName> constraint checks a string is a I<package
 468 name> which is a role, like C<'MyApp::Role::Comparable'>. The C<Role>
 469 constraint checks that an I<object does> the named role.
 470
 471 =head2 Type Constraint Naming
 472
 473 Type name declared via this module can only contain alphanumeric
 474 characters, colons (:), and periods (.).
 475
 476 Since the types created by this module are global, it is suggested
 477 that you namespace your types just as you would namespace your
 478 modules. So instead of creating a I<Color> type for your
 479 B<My::Graphics> module, you would call the type
 480 I<My::Graphics::Types::Color> instead.
 481
 482 =head2 Use with Other Constraint Modules
 483
 484 This module can play nicely with other constraint modules with some
 485 slight tweaking. The C<where> clause in types is expected to be a
 486 C<CODE> reference which checks it's first argument and returns a
 487 boolean. Since most constraint modules work in a similar way, it
 488 should be simple to adapt them to work with Mouse.
 489
 490 For instance, this is how you could use it with
 491 L<Declare::Constraints::Simple> to declare a completely new type.
 492
 493   type 'HashOfArrayOfObjects',
 494       {
 495       where => IsHashRef(
 496           -keys   => HasLength,
 497           -values => IsArrayRef(IsObject)
 498       )
 499   };
 500
 501 Here is an example of using L<Test::Deep> and it's non-test
 502 related C<eq_deeply> function.
 503
 504   type 'ArrayOfHashOfBarsAndRandomNumbers'
 505       => where {
 506           eq_deeply($_,
 507               array_each(subhashof({
 508                   bar           => isa('Bar'),
 509                   random_number => ignore()
 510               })))
 511         };
 512
 513 =head1 METHODS
 514
 515 =head2 optimized_constraints -> HashRef[CODE]
 516
 517 Returns the simple type constraints that Mouse understands.
 518
 519 =head1 FUNCTIONS
 520
 521 =over 4
 522
 523 =item B<subtype 'Name' => as 'Parent' => where { } ...>
 524
 525 =item B<subtype as 'Parent' => where { } ...>
 526
 527 =item B<class_type ($class, ?$options)>
 528
 529 =item B<role_type ($role, ?$options)>
 530
 531 =item B<enum (\@values)>
 532
 533 =back
 534
 535 =head1 THANKS
 536
 537 Much of this documentation was taken from L<Moose::Util::TypeConstraints>
 538
 539 =cut
 540
 541