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