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