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.71_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 For the most part, the only time you will ever encounter an
 305 instance of this class is if you are doing some serious deep
 306 introspection. This API should not be considered final, but
 307 it is B<highly unlikely> that this will matter to a regular
 308 Moose user.
 309
 310 If you wish to use features at this depth, please come to the
 311 #moose IRC channel on irc.perl.org and we can talk :)
 312
 313 =head1 METHODS
 314
 315 =over 4
 316
 317 =item B<meta>
 318
 319 =item B<new>
 320
 321 =item B<equals ($type_name_or_object)>
 322
 323 This checks the current type against the supplied type (only).
 324 Returns false if the two types are not equal. It also returns false if
 325 you provide the type as a name, and the type name isn't found in the
 326 type registry.
 327
 328 =item B<is_a_type_of ($type_name_or_object)>
 329
 330 This checks the current type against the supplied type, or if the
 331 current type is a sub-type of the type name or object supplied. It
 332 also returns false if you provide the type as a name, and the type
 333 name isn't found in the type registry.
 334
 335 =item B<is_subtype_of ($type_name_or_object)>
 336
 337 This checks the current type is a sub-type of the type name or object
 338 supplied. It also returns false if you provide the type as a name, and
 339 the type name isn't found in the type registry.
 340
 341 =item B<compile_type_constraint>
 342
 343 =item B<coerce ($value)>
 344
 345 This will apply the type-coercion if applicable.
 346
 347 =item B<check ($value)>
 348
 349 This method will return a true (C<1>) if the C<$value> passes the
 350 constraint, and false (C<0>) otherwise.
 351
 352 =item B<validate ($value)>
 353
 354 This method is similar to C<check>, but it deals with the error
 355 message. If the C<$value> passes the constraint, C<undef> will be
 356 returned. If the C<$value> does B<not> pass the constraint, then
 357 the C<message> will be used to construct a custom error message.
 358
 359 =item B<name>
 360
 361 The name of the type in the global type registry.
 362
 363 =item B<parent>
 364
 365 This type's parent type.
 366
 367 =item B<has_parent>
 368
 369 Returns true if this type has a parent type.
 370
 371 =item B<parents>
 372
 373 Synonym for C<parent>.
 374
 375 =item B<constraint>
 376
 377 Returns this type's constraint.  This is the value of C<where> provided
 378 when defining a type.
 379
 380 =item B<has_message>
 381
 382 Returns true if this type has a message.
 383
 384 =item B<message>
 385
 386 Returns this type's message.
 387
 388 =item B<get_message ($value)>
 389
 390 Generate message for $value.
 391
 392 =item B<has_coercion>
 393
 394 Returns true if this type has a coercion.
 395
 396 =item B<coercion>
 397
 398 Returns this type's L<Moose::Meta::TypeCoercion> if one exists.
 399
 400 =item B<hand_optimized_type_constraint>
 401
 402 =item B<has_hand_optimized_type_constraint>
 403
 404 =item B<create_child_type>
 405
 406 =back
 407
 408 =head2 DEPRECATED METHOD
 409
 410 =over 4
 411
 412 =item B<union>
 413
 414 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
 415 itself instead.
 416
 417 =back
 418
 419 =head1 BUGS
 420
 421 All complex software has bugs lurking in it, and this module is no
 422 exception. If you find a bug please either email me, or add the bug
 423 to cpan-RT.
 424
 425 =head1 AUTHOR
 426
 427 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 428
 429 =head1 COPYRIGHT AND LICENSE
 430
 431 Copyright 2006-2009 by Infinity Interactive, Inc.
 432
 433 L<http://www.iinteractive.com>
 434
 435 This library is free software; you can redistribute it and/or modify
 436 it under the same terms as Perl itself.
 437
 438 =cut