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