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