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