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 = 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         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 create_child_type {
 424     my ($self, %opts) = @_;
 425     my $class = ref $self;
 426     return $class->new(%opts, parent => $self);
 427 }
 428
 429 1;
 430
 431 # ABSTRACT: The Moose Type Constraint metaclass
 432
 433 __END__
 434
 435 =pod
 436
 437 =head1 DESCRIPTION
 438
 439 This class represents a single type constraint. Moose's built-in type
 440 constraints, as well as constraints you define, are all stored in a
 441 L<Moose::Meta::TypeConstraint::Registry> object as objects of this
 442 class.
 443
 444 =head1 INHERITANCE
 445
 446 C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
 447
 448 =head1 METHODS
 449
 450 =over 4
 451
 452 =item B<< Moose::Meta::TypeConstraint->new(%options) >>
 453
 454 This creates a new type constraint based on the provided C<%options>:
 455
 456 =over 8
 457
 458 =item * name
 459
 460 The constraint name. If a name is not provided, it will be set to
 461 "__ANON__".
 462
 463 =item * parent
 464
 465 A C<Moose::Meta::TypeConstraint> object which is the parent type for
 466 the type being created. This is optional.
 467
 468 =item * constraint
 469
 470 This is the subroutine reference that implements the actual constraint
 471 check. This defaults to a subroutine which always returns true.
 472
 473 =item * message
 474
 475 A subroutine reference which is used to generate an error message when
 476 the constraint fails. This is optional.
 477
 478 =item * coercion
 479
 480 A L<Moose::Meta::TypeCoercion> object representing the coercions to
 481 the type. This is optional.
 482
 483 =item * inlined
 484
 485 A subroutine which returns a string suitable for inlining this type
 486 constraint. It will be called as a method on the type constraint object, and
 487 will receive a single additional parameter, a variable name to be tested
 488 (usually C<"$_"> or C<"$_[0]">.
 489
 490 This is optional.
 491
 492 =item * inline_environment
 493
 494 A hash reference of variables to close over. The keys are variables names, and
 495 the values are I<references> to the variables.
 496
 497 =item * optimized
 498
 499 B<This option is deprecated.>
 500
 501 This is a variant of the C<constraint> parameter that is somehow
 502 optimized. Typically, this means incorporating both the type's
 503 constraint and all of its parents' constraints into a single
 504 subroutine reference.
 505
 506 =back
 507
 508 =item B<< $constraint->equals($type_name_or_object) >>
 509
 510 Returns true if the supplied name or type object is the same as the
 511 current type.
 512
 513 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
 514
 515 Returns true if the supplied name or type object is a parent of the
 516 current type.
 517
 518 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
 519
 520 Returns true if the given type is the same as the current type, or is
 521 a parent of the current type. This is a shortcut for checking
 522 C<equals> and C<is_subtype_of>.
 523
 524 =item B<< $constraint->coerce($value) >>
 525
 526 This will attempt to coerce the value to the type. If the type does not
 527 have any defined coercions this will throw an error.
 528
 529 If no coercion can produce a value matching C<$constraint>, the original
 530 value is returned.
 531
 532 =item B<< $constraint->assert_coerce($value) >>
 533
 534 This method behaves just like C<coerce>, but if the result is not valid
 535 according to C<$constraint>, an error is thrown.
 536
 537 =item B<< $constraint->check($value) >>
 538
 539 Returns true if the given value passes the constraint for the type.
 540
 541 =item B<< $constraint->validate($value) >>
 542
 543 This is similar to C<check>. However, if the type I<is valid> then the
 544 method returns an explicit C<undef>. If the type is not valid, we call
 545 C<< $self->get_message($value) >> internally to generate an error
 546 message.
 547
 548 =item B<< $constraint->assert_valid($value) >>
 549
 550 Like C<check> and C<validate>, this method checks whether C<$value> is
 551 valid under the constraint.  If it is, it will return true.  If it is not,
 552 an exception will be thrown with the results of
 553 C<< $self->get_message($value) >>.
 554
 555 =item B<< $constraint->name >>
 556
 557 Returns the type's name, as provided to the constructor.
 558
 559 =item B<< $constraint->parent >>
 560
 561 Returns the type's parent, as provided to the constructor, if any.
 562
 563 =item B<< $constraint->has_parent >>
 564
 565 Returns true if the type has a parent type.
 566
 567 =item B<< $constraint->parents >>
 568
 569 A synonym for C<parent>. This is useful for polymorphism with types
 570 that can have more than one parent.
 571
 572 =item B<< $constraint->constraint >>
 573
 574 Returns the type's constraint, as provided to the constructor.
 575
 576 =item B<< $constraint->get_message($value) >>
 577
 578 This generates a method for the given value. If the type does not have
 579 an explicit message, we generate a default message.
 580
 581 =item B<< $constraint->has_message >>
 582
 583 Returns true if the type has a message.
 584
 585 =item B<< $constraint->message >>
 586
 587 Returns the type's message as a subroutine reference.
 588
 589 =item B<< $constraint->coercion >>
 590
 591 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
 592 exists.
 593
 594 =item B<< $constraint->has_coercion >>
 595
 596 Returns true if the type has a coercion.
 597
 598 =item B<< $constraint->can_be_inlined >>
 599
 600 Returns true if this type constraint can be inlined. A type constraint which
 601 subtypes an inlinable constraint and does not add an additional constraint
 602 "inherits" its parent type's inlining.
 603
 604 =item B<< $constraint->hand_optimized_type_constraint >>
 605
 606 B<This method is deprecated.>
 607
 608 Returns the type's hand optimized constraint, as provided to the
 609 constructor via the C<optimized> option.
 610
 611 =item B<< $constraint->has_hand_optimized_type_constraint >>
 612
 613 B<This method is deprecated.>
 614
 615 Returns true if the type has an optimized constraint.
 616
 617 =item B<< $constraint->create_child_type(%options) >>
 618
 619 This returns a new type constraint of the same class using the
 620 provided C<%options>. The C<parent> option will be the current type.
 621
 622 This method exists so that subclasses of this class can override this
 623 behavior and change how child types are created.
 624
 625 =back
 626
 627 =head1 BUGS
 628
 629 See L<Moose/BUGS> for details on reporting bugs.
 630
 631 =cut