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