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