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 Class::Load qw(load_class);
  14 use Eval::Closure;
  15 use Scalar::Util qw(blessed refaddr);
  16 use Sub::Name qw(subname);
  17 use Try::Tiny;
  18 use Moose::Util ();
  19
  20 use base qw(Class::MOP::Object);
  21
  22 __PACKAGE__->meta->add_attribute('name'       => (
  23     reader => 'name',
  24     Class::MOP::_definition_context(),
  25 ));
  26 __PACKAGE__->meta->add_attribute('parent'     => (
  27     reader    => 'parent',
  28     predicate => 'has_parent',
  29     Class::MOP::_definition_context(),
  30 ));
  31
  32 my $null_constraint = sub { 1 };
  33 __PACKAGE__->meta->add_attribute('constraint' => (
  34     reader  => 'constraint',
  35     writer  => '_set_constraint',
  36     default => sub { $null_constraint },
  37     Class::MOP::_definition_context(),
  38 ));
  39
  40 __PACKAGE__->meta->add_attribute('message'   => (
  41     accessor  => 'message',
  42     predicate => 'has_message',
  43     Class::MOP::_definition_context(),
  44 ));
  45
  46 __PACKAGE__->meta->add_attribute('_default_message' => (
  47     accessor  => '_default_message',
  48     Class::MOP::_definition_context(),
  49 ));
  50
  51 # can't make this a default because it has to close over the type name, and
  52 # cmop attributes don't have lazy
  53 my $_default_message_generator = sub {
  54     my $name = shift;
  55     sub {
  56         my $value = shift;
  57         # have to load it late like this, since it uses Moose itself
  58         my $can_partialdump = try {
  59             # versions prior to 0.14 had a potential infinite loop bug
  60             load_class('Devel::PartialDump', { -version => 0.14 });
  61             1;
  62         };
  63         if ($can_partialdump) {
  64             $value = Devel::PartialDump->new->dump($value);
  65         }
  66         else {
  67             $value = (defined $value ? overload::StrVal($value) : 'undef');
  68         }
  69         return "Validation failed for '" . $name . "' with value $value";
  70     }
  71 };
  72 __PACKAGE__->meta->add_attribute('coercion'   => (
  73     accessor  => 'coercion',
  74     predicate => 'has_coercion',
  75     Class::MOP::_definition_context(),
  76 ));
  77
  78 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
  79     init_arg  => 'optimized',
  80     accessor  => 'hand_optimized_type_constraint',
  81     predicate => 'has_hand_optimized_type_constraint',
  82     Class::MOP::_definition_context(),
  83 ));
  84
  85 __PACKAGE__->meta->add_attribute('inlined' => (
  86     init_arg  => 'inlined',
  87     accessor  => 'inlined',
  88     predicate => '_has_inlined_type_constraint',
  89     Class::MOP::_definition_context(),
  90 ));
  91
  92 __PACKAGE__->meta->add_attribute('inline_environment' => (
  93     init_arg => 'inline_environment',
  94     accessor => '_inline_environment',
  95     default  => sub { {} },
  96     Class::MOP::_definition_context(),
  97 ));
  98
  99 sub parents {
 100     my $self = shift;
 101     $self->parent;
 102 }
 103
 104 # private accessors
 105
 106 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
 107     accessor  => '_compiled_type_constraint',
 108     predicate => '_has_compiled_type_constraint',
 109     Class::MOP::_definition_context(),
 110 ));
 111
 112 __PACKAGE__->meta->add_attribute('package_defined_in' => (
 113     accessor => '_package_defined_in',
 114     Class::MOP::_definition_context(),
 115 ));
 116
 117 sub new {
 118     my $class = shift;
 119     my ($first, @rest) = @_;
 120     my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
 121     $args{name} = $args{name} ? "$args{name}" : "__ANON__";
 122
 123     if ( $args{optimized} ) {
 124         Moose::Deprecated::deprecated(
 125             feature => 'optimized type constraint sub ref',
 126             message =>
 127                 'Providing an optimized subroutine ref for type constraints is deprecated.'
 128                 . ' Use the inlining feature (inline_as) instead.'
 129         );
 130     }
 131
 132     if ( exists $args{message}
 133       && (!ref($args{message}) || ref($args{message}) ne 'CODE') ) {
 134         Moose::Util::throw("The 'message' parameter must be a coderef");
 135     }
 136
 137     my $self  = $class->_new(%args);
 138     $self->compile_type_constraint()
 139         unless $self->_has_compiled_type_constraint;
 140     $self->_default_message($_default_message_generator->($self->name))
 141         unless $self->has_message;
 142     return $self;
 143 }
 144
 145
 146
 147 sub coerce {
 148     my $self = shift;
 149
 150     my $coercion = $self->coercion;
 151
 152     unless ($coercion) {
 153         Moose::Util::throw("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         Moose::Util::throw("Cannot coerce without a type coercion");
 168     }
 169
 170     return $_[0] if $self->check($_[0]);
 171
 172     my $result = $coercion->coerce(@_);
 173
 174     $self->assert_valid($result);
 175
 176     return $result;
 177 }
 178
 179 sub check {
 180     my ($self, @args) = @_;
 181     my $constraint_subref = $self->_compiled_type_constraint;
 182     return $constraint_subref->(@args) ? 1 : undef;
 183 }
 184
 185 sub validate {
 186     my ($self, $value) = @_;
 187     if ($self->_compiled_type_constraint->($value)) {
 188         return undef;
 189     }
 190     else {
 191         $self->get_message($value);
 192     }
 193 }
 194
 195 sub can_be_inlined {
 196     my $self = shift;
 197
 198     if ( $self->has_parent && $self->constraint == $null_constraint ) {
 199         return $self->parent->can_be_inlined;
 200     }
 201
 202     return $self->_has_inlined_type_constraint;
 203 }
 204
 205 sub _inline_check {
 206     my $self = shift;
 207
 208     unless ( $self->can_be_inlined ) {
 209         Moose::Util::throw( 'Cannot inline a type constraint check for ' . $self->name );
 210     }
 211
 212     if ( $self->has_parent && $self->constraint == $null_constraint ) {
 213         return $self->parent->_inline_check(@_);
 214     }
 215
 216     return '( do { ' . $self->inlined->( $self, @_ ) . ' } )';
 217 }
 218
 219 sub inline_environment {
 220     my $self = shift;
 221
 222     if ( $self->has_parent && $self->constraint == $null_constraint ) {
 223         return $self->parent->inline_environment;
 224     }
 225
 226     return $self->_inline_environment;
 227 }
 228
 229 sub assert_valid {
 230     my ($self, $value) = @_;
 231
 232     my $error = $self->validate($value);
 233     return 1 if ! defined $error;
 234
 235     Moose::Util::throw(
 236         message   => $error,
 237         class     => 'Moose::Exception::TypeConstraint',
 238         type_name => $self->name,
 239         value     => $value,
 240     );
 241 }
 242
 243 sub get_message {
 244     my ($self, $value) = @_;
 245     my $msg = $self->has_message
 246         ? $self->message
 247         : $self->_default_message;
 248     local $_ = $value;
 249     return $msg->($value);
 250 }
 251
 252 ## type predicates ...
 253
 254 sub equals {
 255     my ( $self, $type_or_name ) = @_;
 256
 257     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
 258
 259     return 1 if $self == $other;
 260
 261     if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
 262         return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
 263     }
 264
 265     return unless $self->constraint == $other->constraint;
 266
 267     if ( $self->has_parent ) {
 268         return unless $other->has_parent;
 269         return unless $self->parent->equals( $other->parent );
 270     } else {
 271         return if $other->has_parent;
 272     }
 273
 274     return;
 275 }
 276
 277 sub is_a_type_of {
 278     my ($self, $type_or_name) = @_;
 279
 280     my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
 281
 282     ($self->equals($type) || $self->is_subtype_of($type));
 283 }
 284
 285 sub is_subtype_of {
 286     my ($self, $type_or_name) = @_;
 287
 288     my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
 289
 290     my $current = $self;
 291
 292     while (my $parent = $current->parent) {
 293         return 1 if $parent->equals($type);
 294         $current = $parent;
 295     }
 296
 297     return 0;
 298 }
 299
 300 ## compiling the type constraint
 301
 302 sub compile_type_constraint {
 303     my $self = shift;
 304     $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
 305 }
 306
 307 ## type compilers ...
 308
 309 sub _actually_compile_type_constraint {
 310     my $self = shift;
 311
 312     return $self->_compile_hand_optimized_type_constraint
 313         if $self->has_hand_optimized_type_constraint;
 314
 315     if ( $self->can_be_inlined ) {
 316         return eval_closure(
 317             source      => 'sub { ' . $self->_inline_check('$_[0]') . ' }',
 318             environment => $self->inline_environment,
 319         );
 320     }
 321
 322     my $check = $self->constraint;
 323     unless ( defined $check ) {
 324         Moose::Util::throw( "Could not compile type constraint '"
 325                 . $self->name
 326                 . "' because no constraint check" );
 327     }
 328
 329     return $self->_compile_subtype($check)
 330         if $self->has_parent;
 331
 332     return $self->_compile_type($check);
 333 }
 334
 335 sub _compile_hand_optimized_type_constraint {
 336     my $self = shift;
 337
 338     my $type_constraint = $self->hand_optimized_type_constraint;
 339
 340     unless ( ref $type_constraint ) {
 341         Moose::Util::throw("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 Returns all of the types parents as an list of type constraint objects.
 569
 570 =item B<< $constraint->constraint >>
 571
 572 Returns the type's constraint, as provided to the constructor.
 573
 574 =item B<< $constraint->get_message($value) >>
 575
 576 This generates a method for the given value. If the type does not have
 577 an explicit message, we generate a default message.
 578
 579 =item B<< $constraint->has_message >>
 580
 581 Returns true if the type has a message.
 582
 583 =item B<< $constraint->message >>
 584
 585 Returns the type's message as a subroutine reference.
 586
 587 =item B<< $constraint->coercion >>
 588
 589 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
 590 exists.
 591
 592 =item B<< $constraint->has_coercion >>
 593
 594 Returns true if the type has a coercion.
 595
 596 =item B<< $constraint->can_be_inlined >>
 597
 598 Returns true if this type constraint can be inlined. A type constraint which
 599 subtypes an inlinable constraint and does not add an additional constraint
 600 "inherits" its parent type's inlining.
 601
 602 =item B<< $constraint->hand_optimized_type_constraint >>
 603
 604 B<This method is deprecated.>
 605
 606 Returns the type's hand optimized constraint, as provided to the
 607 constructor via the C<optimized> option.
 608
 609 =item B<< $constraint->has_hand_optimized_type_constraint >>
 610
 611 B<This method is deprecated.>
 612
 613 Returns true if the type has an optimized constraint.
 614
 615 =item B<< $constraint->create_child_type(%options) >>
 616
 617 This returns a new type constraint of the same class using the
 618 provided C<%options>. The C<parent> option will be the current type.
 619
 620 This method exists so that subclasses of this class can override this
 621 behavior and change how child types are created.
 622
 623 =back
 624
 625 =head1 BUGS
 626
 627 See L<Moose/BUGS> for details on reporting bugs.
 628
 629 =cut