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