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