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