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     my $check = $self->constraint;
 238     unless ( defined $check ) {
 239         require Moose;
 240         Moose->throw_error( "Could not compile type constraint '"
 241                 . $self->name
 242                 . "' because no constraint check" );
 243     }
 244
 245     return $self->_compile_subtype($check)
 246         if $self->has_parent;
 247
 248     return $self->_compile_type($check);
 249 }
 250
 251 sub _compile_hand_optimized_type_constraint {
 252     my $self = shift;
 253
 254     my $type_constraint = $self->hand_optimized_type_constraint;
 255
 256     unless ( ref $type_constraint ) {
 257         require Moose;
 258         Moose->throw_error("Hand optimized type constraint is not a code reference");
 259     }
 260
 261     return $type_constraint;
 262 }
 263
 264 sub _compile_subtype {
 265     my ($self, $check) = @_;
 266
 267     # gather all the parent constraintss in order
 268     my @parents;
 269     my $optimized_parent;
 270     foreach my $parent ($self->_collect_all_parents) {
 271         # if a parent is optimized, the optimized constraint already includes
 272         # all of its parents tcs, so we can break the loop
 273         if ($parent->has_hand_optimized_type_constraint) {
 274             push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
 275             last;
 276         }
 277         else {
 278             push @parents => $parent->constraint;
 279         }
 280     }
 281
 282     @parents = grep { $_ != $null_constraint } reverse @parents;
 283
 284     unless ( @parents ) {
 285         return $self->_compile_type($check);
 286     } elsif( $optimized_parent and @parents == 1 ) {
 287         # the case of just one optimized parent is optimized to prevent
 288         # looping and the unnecessary localization
 289         if ( $check == $null_constraint ) {
 290             return $optimized_parent;
 291         } else {
 292             return subname($self->name, sub {
 293                 return undef unless $optimized_parent->($_[0]);
 294                 my (@args) = @_;
 295                 local $_ = $args[0];
 296                 $check->(@args);
 297             });
 298         }
 299     } else {
 300         # general case, check all the constraints, from the first parent to ourselves
 301         my @checks = @parents;
 302         push @checks, $check if $check != $null_constraint;
 303         return subname($self->name => sub {
 304             my (@args) = @_;
 305             local $_ = $args[0];
 306             foreach my $check (@checks) {
 307                 return undef unless $check->(@args);
 308             }
 309             return 1;
 310         });
 311     }
 312 }
 313
 314 sub _compile_type {
 315     my ($self, $check) = @_;
 316
 317     return $check if $check == $null_constraint; # Item, Any
 318
 319     return subname($self->name => sub {
 320         my (@args) = @_;
 321         local $_ = $args[0];
 322         $check->(@args);
 323     });
 324 }
 325
 326 ## other utils ...
 327
 328 sub _collect_all_parents {
 329     my $self = shift;
 330     my @parents;
 331     my $current = $self->parent;
 332     while (defined $current) {
 333         push @parents => $current;
 334         $current = $current->parent;
 335     }
 336     return @parents;
 337 }
 338
 339 sub create_child_type {
 340     my ($self, %opts) = @_;
 341     my $class = ref $self;
 342     return $class->new(%opts, parent => $self);
 343 }
 344
 345 1;
 346
 347 # ABSTRACT: The Moose Type Constraint metaclass
 348
 349 __END__
 350
 351 =pod
 352
 353 =head1 DESCRIPTION
 354
 355 This class represents a single type constraint. Moose's built-in type
 356 constraints, as well as constraints you define, are all stored in a
 357 L<Moose::Meta::TypeConstraint::Registry> object as objects of this
 358 class.
 359
 360 =head1 INHERITANCE
 361
 362 C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
 363
 364 =head1 METHODS
 365
 366 =over 4
 367
 368 =item B<< Moose::Meta::TypeConstraint->new(%options) >>
 369
 370 This creates a new type constraint based on the provided C<%options>:
 371
 372 =over 8
 373
 374 =item * name
 375
 376 The constraint name. If a name is not provided, it will be set to
 377 "__ANON__".
 378
 379 =item * parent
 380
 381 A C<Moose::Meta::TypeConstraint> object which is the parent type for
 382 the type being created. This is optional.
 383
 384 =item * constraint
 385
 386 This is the subroutine reference that implements the actual constraint
 387 check. This defaults to a subroutine which always returns true.
 388
 389 =item * message
 390
 391 A subroutine reference which is used to generate an error message when
 392 the constraint fails. This is optional.
 393
 394 =item * coercion
 395
 396 A L<Moose::Meta::TypeCoercion> object representing the coercions to
 397 the type. This is optional.
 398
 399 =item * optimized
 400
 401 This is a variant of the C<constraint> parameter that is somehow
 402 optimized. Typically, this means incorporating both the type's
 403 constraint and all of its parents' constraints into a single
 404 subroutine reference.
 405
 406 =back
 407
 408 =item B<< $constraint->equals($type_name_or_object) >>
 409
 410 Returns true if the supplied name or type object is the same as the
 411 current type.
 412
 413 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
 414
 415 Returns true if the supplied name or type object is a parent of the
 416 current type.
 417
 418 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
 419
 420 Returns true if the given type is the same as the current type, or is
 421 a parent of the current type. This is a shortcut for checking
 422 C<equals> and C<is_subtype_of>.
 423
 424 =item B<< $constraint->coerce($value) >>
 425
 426 This will attempt to coerce the value to the type. If the type does not
 427 have any defined coercions this will throw an error.
 428
 429 If no coercion can produce a value matching C<$constraint>, the original
 430 value is returned.
 431
 432 =item B<< $constraint->assert_coerce($value) >>
 433
 434 This method behaves just like C<coerce>, but if the result is not valid
 435 according to C<$constraint>, an error is thrown.
 436
 437 =item B<< $constraint->check($value) >>
 438
 439 Returns true if the given value passes the constraint for the type.
 440
 441 =item B<< $constraint->validate($value) >>
 442
 443 This is similar to C<check>. However, if the type I<is valid> then the
 444 method returns an explicit C<undef>. If the type is not valid, we call
 445 C<< $self->get_message($value) >> internally to generate an error
 446 message.
 447
 448 =item B<< $constraint->assert_valid($value) >>
 449
 450 Like C<check> and C<validate>, this method checks whether C<$value> is
 451 valid under the constraint.  If it is, it will return true.  If it is not,
 452 an exception will be thrown with the results of
 453 C<< $self->get_message($value) >>.
 454
 455 =item B<< $constraint->name >>
 456
 457 Returns the type's name, as provided to the constructor.
 458
 459 =item B<< $constraint->parent >>
 460
 461 Returns the type's parent, as provided to the constructor, if any.
 462
 463 =item B<< $constraint->has_parent >>
 464
 465 Returns true if the type has a parent type.
 466
 467 =item B<< $constraint->parents >>
 468
 469 A synonym for C<parent>. This is useful for polymorphism with types
 470 that can have more than one parent.
 471
 472 =item B<< $constraint->constraint >>
 473
 474 Returns the type's constraint, as provided to the constructor.
 475
 476 =item B<< $constraint->get_message($value) >>
 477
 478 This generates a method for the given value. If the type does not have
 479 an explicit message, we generate a default message.
 480
 481 =item B<< $constraint->has_message >>
 482
 483 Returns true if the type has a message.
 484
 485 =item B<< $constraint->message >>
 486
 487 Returns the type's message as a subroutine reference.
 488
 489 =item B<< $constraint->coercion >>
 490
 491 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
 492 exists.
 493
 494 =item B<< $constraint->has_coercion >>
 495
 496 Returns true if the type has a coercion.
 497
 498 =item B<< $constraint->hand_optimized_type_constraint >>
 499
 500 Returns the type's hand optimized constraint, as provided to the
 501 constructor via the C<optimized> option.
 502
 503 =item B<< $constraint->has_hand_optimized_type_constraint >>
 504
 505 Returns true if the type has an optimized constraint.
 506
 507 =item B<< $constraint->create_child_type(%options) >>
 508
 509 This returns a new type constraint of the same class using the
 510 provided C<%options>. The C<parent> option will be the current type.
 511
 512 This method exists so that subclasses of this class can override this
 513 behavior and change how child types are created.
 514
 515 =back
 516
 517 =head1 BUGS
 518
 519 See L<Moose/BUGS> for details on reporting bugs.
 520
 521 =cut