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