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