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.72_01';
  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 ## this should get deprecated actually ...
 289
 290 sub union { Carp::croak "DEPRECATED" }
 291
 292 1;
 293
 294 __END__
 295
 296 =pod
 297
 298 =head1 NAME
 299
 300 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
 301
 302 =head1 DESCRIPTION
 303
 304 This class represents a single type constraint. Moose's built-in type
 305 constraints, as well as constraints you define, are all store in a
 306 L<Moose::Meta::TypeConstraint::Registry> object as objects of this
 307 class.
 308
 309 =head1 INHERITANCE
 310
 311 C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
 312
 313 =head1 METHODS
 314
 315 =over 4
 316
 317 =item B<< Moose::Meta::TypeConstraint->new(%options) >>
 318
 319 This creates a new type constraint based on the provided C<%options>:
 320
 321 =over 8
 322
 323 =item * name
 324
 325 The constraint name. If a name is not provided, it will be set to
 326 "__ANON__".
 327
 328 =item * parent
 329
 330 A C<Moose::Meta::TypeConstraint> object which is the parent type for
 331 the type being created. This is optional.
 332
 333 =item * constraint
 334
 335 This is the subroutine reference that implements the actual constraint
 336 check. This defaults to a subroutine which always returns true.
 337
 338 =item * message
 339
 340 A subroutine reference which is used to generate an error message when
 341 the constraint fails. This is optional.
 342
 343 =item * coercion
 344
 345 A L<Moose::Meta::TypeCoercion> object representing the coercions to
 346 the type. This is optional.
 347
 348 =item * optimized
 349
 350 This is a variant of the C<constraint> parameter that is somehow
 351 optimized. Typically, this means incorporating both the type's
 352 constraint and all of its parents' constraints into a single
 353 subroutine reference.
 354
 355 =back
 356
 357 =item B<< $constraint->equals($type_name_or_object) >>
 358
 359 Returns true if the supplied name or type object is the same as the
 360 current type.
 361
 362 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
 363
 364 Returns true if the supplied name or type object is a parent of the
 365 current type.
 366
 367 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
 368
 369 Returns true if the given type is the same as the current type, or is
 370 a parent of the current type. This is a shortcut for checking
 371 C<equals> and C<is_subtype_of>.
 372
 373 =item B<< $constraint->coerce($value) >>
 374
 375 This will attempt to coerce the value to the type. If the type does
 376 have any defined coercions this will throw an error.
 377
 378 =item B<< $constraint->check($value) >>
 379
 380 Returns true if the given value passes the constraint for the type.
 381
 382 =item B<< $constraint->validate($value) >>
 383
 384 This is similar to C<check>. However, if the type I<is valid> then the
 385 method returns an explicit C<undef>. If the type is not valid, we call
 386 C<< $self->get_message($value) >> internally to generate an error
 387 message.
 388
 389 =item B<< $constraint->name >>
 390
 391 Returns the type's name, as provided to the constructor.
 392
 393 =item B<< $constraint->parent >>
 394
 395 Returns the type's parent, as provided to the constructor, if any.
 396
 397 =item B<< $constraint->has_parent >>
 398
 399 Returns true if the type has a parent type.
 400
 401 =item B<< $constraint->parents >>
 402
 403 A synonym for C<parent>. This is useful for polymorphism with types
 404 that can have more than one parent.
 405
 406 =item B<< $constraint->constraint >>
 407
 408 Returns the type's constraint, as provided to the constructor.
 409
 410 =item B<< $constraint->get_message($value) >>
 411
 412 This generates a method for the given value. If the type does not have
 413 an explicit message, we generate a default message.
 414
 415 =item B<< $constraint->has_message >>
 416
 417 Returns true if the type has a message.
 418
 419 =item B<< $constraint->message >>
 420
 421 Returns the type's message as a subroutine reference.
 422
 423 =item B<< $constraint->coercion >>
 424
 425 Returns the type's L<Moose::Meta::TypeCoercion> object, if one
 426 exists.
 427
 428 =item B<< $constraint->has_coercion >>
 429
 430 Returns true if the type has a coercion.
 431
 432 =item B<< $constraint->hand_optimized_type_constraint >>
 433
 434 Returns the type's hand optimized constraint, as provided to the
 435 constructor via the C<optimized> option.
 436
 437 =item B<< $constraint->has_hand_optimized_type_constraint >>
 438
 439 Returns true if the type has an optimized constraint.
 440
 441 =item B<< $constraint->create_child_type(%options) >>
 442
 443 This returns a new type constraint of the same class using the
 444 provided C<%options>. The C<parent> option will be the current type.
 445
 446 This method exists so that subclasses of this class can override this
 447 behavior and change how child types are created.
 448
 449 =back
 450
 451 =head1 BUGS
 452
 453 All complex software has bugs lurking in it, and this module is no
 454 exception. If you find a bug please either email me, or add the bug
 455 to cpan-RT.
 456
 457 =head1 AUTHOR
 458
 459 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 460
 461 =head1 COPYRIGHT AND LICENSE
 462
 463 Copyright 2006-2009 by Infinity Interactive, Inc.
 464
 465 L<http://www.iinteractive.com>
 466
 467 This library is free software; you can redistribute it and/or modify
 468 it under the same terms as Perl itself.
 469
 470 =cut