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