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