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