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