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