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