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