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