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