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