lib/Moose/Meta/TypeConstraint.pm

   1
   2 package Moose::Meta::TypeConstraint;
   3
   4 use strict;
   5 use warnings;
   6 use metaclass;
   7
   8 use overload '0+'     => sub { refaddr(shift) }, # id an object
   9              '""'     => sub { shift->name },   # stringify to tc name
  10              bool     => sub { 1 },
  11              fallback => 1;
  12
  13 use Eval::Closure;
  14 use Scalar::Util qw(blessed refaddr);
  15 use Sub::Name qw(subname);
  16 use Try::Tiny;
  17
  18 use base qw(Class::MOP::Object);
  19
  20 __PACKAGE__->meta->add_attribute('name'       => (reader => 'name'));
  21 __PACKAGE__->meta->add_attribute('parent'     => (
  22     reader    => 'parent',
  23     predicate => 'has_parent',
  24 ));
  25
  26 my $null_constraint = sub { 1 };
  27 __PACKAGE__->meta->add_attribute('constraint' => (
  28     reader  => 'constraint',
  29     writer  => '_set_constraint',
  30     default => sub { $null_constraint }
  31 ));
  32 __PACKAGE__->meta->add_attribute('message'   => (
  33     accessor  => 'message',
  34     predicate => 'has_message'
  35 ));
  36 __PACKAGE__->meta->add_attribute('coercion'   => (
  37     accessor  => 'coercion',
  38     predicate => 'has_coercion'
  39 ));
  40
  41 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
  42     init_arg  => 'optimized',
  43     accessor  => 'hand_optimized_type_constraint',
  44     predicate => 'has_hand_optimized_type_constraint',
  45 ));
  46
  47 __PACKAGE__->meta->add_attribute('inlined' => (
  48     init_arg  => 'inlined',
  49     accessor  => 'inlined',
  50     predicate => '_has_inlined_type_constraint',
  51 ));
  52
  53 __PACKAGE__->meta->add_attribute('inline_environment' => (
  54     init_arg => 'inline_environment',
  55     accessor => 'inline_environment',
  56     default  => sub { {} },
  57 ));
  58
  59 sub parents {
  60     my $self;
  61     $self->parent;
  62 }
  63
  64 # private accessors
  65
  66 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
  67     accessor  => '_compiled_type_constraint',
  68     predicate => '_has_compiled_type_constraint'
  69 ));
  70 __PACKAGE__->meta->add_attribute('package_defined_in' => (
  71     accessor => '_package_defined_in'
  72 ));
  73
  74 sub new {
  75     my $class = shift;
  76     my ($first, @rest) = @_;
  77     my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
  78     $args{name} = $args{name} ? "$args{name}" : "__ANON__";
  79
  80     my $self  = $class->_new(%args);
  81     $self->compile_type_constraint()
  82         unless $self->_has_compiled_type_constraint;
  83     return $self;
  84 }
  85
  86
  87
  88 sub coerce {
  89     my $self = shift;
  90
  91     my $coercion = $self->coercion;
  92
  93     unless ($coercion) {
  94         require Moose;
  95         Moose->throw_error("Cannot coerce without a type coercion");
  96     }
  97
  98     return $_[0] if $self->check($_[0]);
  99
 100     return $coercion->coerce(@_);
 101 }
 102
 103 sub assert_coerce {
 104     my $self = shift;
 105
 106     my $coercion = $self->coercion;
 107
 108     unless ($coercion) {
 109         require Moose;
 110         Moose->throw_error("Cannot coerce without a type coercion");
 111     }
 112
 113     return $_[0] if $self->check($_[0]);
 114
 115     my $result = $coercion->coerce(@_);
 116
 117     $self->assert_valid($result);
 118
 119     return $result;
 120 }
 121
 122 sub check {
 123     my ($self, @args) = @_;
 124     my $constraint_subref = $self->_compiled_type_constraint;
 125     return $constraint_subref->(@args) ? 1 : undef;
 126 }
 127
 128 sub validate {
 129     my ($self, $value) = @_;
 130     if ($self->_compiled_type_constraint->($value)) {
 131         return undef;
 132     }
 133     else {
 134         $self->get_message($value);
 135     }
 136 }
 137
 138 sub has_inlined_type_constraint {
 139     my $self = shift;
 140
 141     if ( $self->has_parent && $self->constraint == $null_constraint ) {
 142         return $self->parent->has_inlined_type_constraint;
 143     }
 144
 145     return $self->_has_inlined_type_constraint;
 146 }
 147
 148 sub _inline_check {
 149     my $self = shift;
 150
 151     unless ( $self->has_inlined_type_constraint ) {
 152         require Moose;
 153         Moose->throw_error( 'Cannot inline a type constraint check for ' . $self->name );
 154     }
 155
 156     if ( $self->has_parent && $self->constraint == $null_constraint ) {
 157         return $self->parent->_inline_check(@_);
 158     }
 159
 160     return $self->inlined->( $self, @_ );
 161 }
 162
 163 sub assert_valid {
 164     my ($self, $value) = @_;
 165
 166     my $error = $self->validate($value);
 167     return 1 if ! defined $error;
 168
 169     require Moose;
 170     Moose->throw_error($error);
 171 }
 172
 173 sub get_message {
 174     my ($self, $value) = @_;
 175     if (my $msg = $self->message) {
 176         local $_ = $value;
 177         return $msg->($value);
 178     }
 179     else {
 180         # have to load it late like this, since it uses Moose itself
 181         my $can_partialdump = try {
 182             # versions prior to 0.14 had a potential infinite loop bug
 183             Class::MOP::load_class('Devel::PartialDump', { -version => 0.14 });
 184             1;
 185         };
 186         if ($can_partialdump) {
 187             $value = Devel::PartialDump->new->dump($value);
 188         }
 189         else {
 190             $value = (defined $value ? overload::StrVal($value) : 'undef');
 191         }
 192         return "Validation failed for '" . $self->name . "' with value $value";
 193     }
 194 }
 195
 196 ## type predicates ...
 197
 198 sub equals {
 199     my ( $self, $type_or_name ) = @_;
 200
 201     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
 202
 203     return 1 if $self == $other;
 204
 205     if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
 206         return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
 207     }
 208
 209     return unless $self->constraint == $other->constraint;
 210
 211     if ( $self->has_parent ) {
 212         return unless $other->has_parent;
 213         return unless $self->parent->equals( $other->parent );
 214     } else {
 215         return if $other->has_parent;
 216     }
 217
 218     return;
 219 }
 220
 221 sub is_a_type_of {
 222     my ($self, $type_or_name) = @_;
 223
 224     my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
 225
 226     ($self->equals($type) || $self->is_subtype_of($type));
 227 }
 228
 229 sub is_subtype_of {
 230     my ($self, $type_or_name) = @_;
 231
 232     my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
 233
 234     my $current = $self;
 235
 236     while (my $parent = $current->parent) {
 237         return 1 if $parent->equals($type);
 238         $current = $parent;
 239     }
 240
 241     return 0;
 242 }
 243
 244 ## compiling the type constraint
 245
 246 sub compile_type_constraint {
 247     my $self = shift;
 248     $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
 249 }
 250
 251 ## type compilers ...
 252
 253 sub _actually_compile_type_constraint {
 254     my $self = shift;
 255
 256     return $self->_compile_hand_optimized_type_constraint
 257         if $self->has_hand_optimized_type_constraint;
 258
 259     if ( $self->has_inlined_type_constraint ) {
 260         return eval_closure(
 261             source      => 'sub { ' . $self->_inline_check('$_[0]') . ' }',
 262             environment => $self->inline_environment,
 263         );
 264     }
 265
 266     my $check = $self->constraint;
 267     unless ( defined $check ) {
 268         require Moose;
 269         Moose->throw_error( "Could not compile type constraint '"
 270                 . $self->name
 271                 . "' because no constraint check" );
 272     }
 273
 274     return $self->_compile_subtype($check)
 275         if $self->has_parent;
 276
 277     return $self->_compile_type($check);
 278 }
 279
 280 sub _compile_hand_optimized_type_constraint {
 281     my $self = shift;
 282
 283     my $type_constraint = $self->hand_optimized_type_constraint;
 284
 285     unless ( ref $type_constraint ) {
 286         require Moose;
 287         Moose->throw_error("Hand optimized type constraint is not a code reference");
 288     }
 289
 290     return $type_constraint;
 291 }
 292
 293 sub _compile_subtype {
 294     my ($self, $check) = @_;
 295
 296     # gather all the parent constraintss in order
 297     my @parents;
 298     my $optimized_parent;
 299     foreach my $parent ($self->_collect_all_parents) {
 300         # if a parent is optimized, the optimized constraint already includes
 301         # all of its parents tcs, so we can break the loop
 302         if ($parent->has_hand_optimized_type_constraint) {
 303             push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
 304             last;
 305         }
 306         else {
 307             push @parents => $parent->constraint;
 308         }
 309     }
 310
 311     @parents = grep { $_ != $null_constraint } reverse @parents;
 312
 313     unless ( @parents ) {
 314         return $self->_compile_type($check);
 315     } elsif( $optimized_parent and @parents == 1 ) {
 316         # the case of just one optimized parent is optimized to prevent
 317         # looping and the unnecessary localization
 318         if ( $check == $null_constraint ) {
 319             return $optimized_parent;
 320         } else {
 321             return subname($self->name, sub {
 322                 return undef unless $optimized_parent->($_[0]);
 323                 my (@args) = @_;
 324                 local $_ = $args[0];
 325                 $check->(@args);
 326             });
 327         }
 328     } else {
 329         # general case, check all the constraints, from the first parent to ourselves
 330         my @checks = @parents;
 331         push @checks, $check if $check != $null_constraint;
 332         return subname($self->name => sub {
 333             my (@args) = @_;
 334             local $_ = $args[0];
 335             foreach my $check (@checks) {
 336                 return undef unless $check->(@args);
 337             }
 338             return 1;
 339         });
 340     }
 341 }
 342
 343 sub _compile_type {
 344     my ($self, $check) = @_;
 345
 346     return $check if $check == $null_constraint; # Item, Any
 347
 348     return subname($self->name => sub {
 349         my (@args) = @_;
 350         local $_ = $args[0];
 351         $check->(@args);
 352     });
 353 }
 354
 355 ## other utils ...
 356
 357 sub _collect_all_parents {
 358     my $self = shift;
 359     my @parents;
 360     my $current = $self->parent;
 361     while (defined $current) {
 362         push @parents => $current;
 363         $current = $current->parent;
 364     }
 365     return @parents;
 366 }
 367
 368 sub create_child_type {
 369     my ($self, %opts) = @_;
 370     my $class = ref $self;
 371     return $class->new(%opts, parent => $self);
 372 }
 373
 374 1;
 375
 376 # ABSTRACT: The Moose Type Constraint metaclass
 377
 378 __END__
 379
 380 =pod
 381
 382 =head1 DESCRIPTION
 383
 384 This class represents a single type constraint. Moose's built-in type
 385 constraints, as well as constraints you define, are all stored in a
 386 L<Moose::Meta::TypeConstraint::Registry> object as objects of this
 387 class.
 388
 389 =head1 INHERITANCE
 390
 391 C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
 392
 393 =head1 METHODS
 394
 395 =over 4
 396
 397 =item B<< Moose::Meta::TypeConstraint->new(%options) >>
 398
 399 This creates a new type constraint based on the provided C<%options>:
 400
 401 =over 8
 402
 403 =item * name
 404
 405 The constraint name. If a name is not provided, it will be set to
 406 "__ANON__".
 407
 408 =item * parent
 409
 410 A C<Moose::Meta::TypeConstraint> object which is the parent type for
 411 the type being created. This is optional.
 412
 413 =item * constraint
 414
 415 This is the subroutine reference that implements the actual constraint
 416 check. This defaults to a subroutine which always returns true.
 417
 418 =item * message
 419
 420 A subroutine reference which is used to generate an error message when
 421 the constraint fails. This is optional.
 422
 423 =item * coercion
 424
 425 A L<Moose::Meta::TypeCoercion> object representing the coercions to
 426 the type. This is optional.
 427
 428 =item * optimized
 429
 430 This is a variant of the C<constraint> parameter that is somehow
 431 optimized. Typically, this means incorporating both the type's
 432 constraint and all of its parents' constraints into a single
 433 subroutine reference.
 434
 435 =back
 436
 437 =item B<< $constraint->equals($type_name_or_object) >>
 438
 439 Returns true if the supplied name or type object is the same as the
 440 current type.
 441
 442 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
 443
 444 Returns true if the supplied name or type object is a parent of the
 445 current type.
 446
 447 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
 448
 449 Returns true if the given type is the same as the current type, or is
 450 a parent of the current type. This is a shortcut for checking
 451 C<equals> and C<is_subtype_of>.
 452
 453 =item B<< $constraint->coerce($value) >>
 454
 455 This will attempt to coerce the value to the type. If the type does not
 456 have any defined coercions this will throw an error.
 457
 458 If no coercion can produce a value matching C<$constraint>, the original
 459 value is returned.
 460
 461 =item B<< $constraint->assert_coerce($value) >>
 462
 463 This method behaves just like C<coerce>, but if the result is not valid
 464 according to C<$constraint>, an error is thrown.
 465
 466 =item B<< $constraint->check($value) >>
 467
 468 Returns true if the given value passes the constraint for the type.
 469
 470 =item B<< $constraint->validate($value) >>
 471
 472 This is similar to C<check>. However, if the type I<is valid> then the
 473 method returns an explicit C<undef>. If the type is not valid, we call
 474 C<< $self->get_message($value) >> internally to generate an error
 475 message.
 476
 477 =item B<< $constraint->assert_valid($value) >>
 478
 479 Like C<check> and C<validate>, this method checks whether C<$value> is
 480 valid under the constraint.  If it is, it will return true.  If it is not,
 481 an exception will be thrown with the results of
 482 C<< $self->get_message($value) >>.
 483
 484 =item B<< $constraint->name >>
 485
 486 Returns the type's name, as provided to the constructor.
 487
 488 =item B<< $constraint->parent >>
 489
 490 Returns the type's parent, as provided to the constructor, if any.
 491
 492 =item B<< $constraint->has_parent >>
 493
 494 Returns true if the type has a parent type.
 495
 496 =item B<< $constraint->parents >>
 497
 498 A synonym for C<parent>. This is useful for polymorphism with types
 499 that can have more than one parent.
 500
 501 =item B<< $constraint->constraint >>
 502
 503 Returns the type's constraint, as provided to the constructor.
 504
 505 =item B<< $constraint->get_message($value) >>
 506
 507 This generates a method for the given value. If the type does not have
 508 an explicit message, we generate a default message.
 509
 510 =item B<< $constraint->has_message >>
 511
 512 Returns true if the type has a message.
 513
 514 =item B<< $constraint->message >>
 515
 516 Returns the type's message as a subroutine reference.
 517
 518 =item B<< $constraint->coercion >>
 519
 520 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
 521 exists.
 522
 523 =item B<< $constraint->has_coercion >>
 524
 525 Returns true if the type has a coercion.
 526
 527 =item B<< $constraint->hand_optimized_type_constraint >>
 528
 529 Returns the type's hand optimized constraint, as provided to the
 530 constructor via the C<optimized> option.
 531
 532 =item B<< $constraint->has_hand_optimized_type_constraint >>
 533
 534 Returns true if the type has an optimized constraint.
 535
 536 =item B<< $constraint->create_child_type(%options) >>
 537
 538 This returns a new type constraint of the same class using the
 539 provided C<%options>. The C<parent> option will be the current type.
 540
 541 This method exists so that subclasses of this class can override this
 542 behavior and change how child types are created.
 543
 544 =back
 545
 546 =head1 BUGS
 547
 548 See L<Moose/BUGS> for details on reporting bugs.
 549
 550 =cut