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