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