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