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.66';
  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 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
  40     init_arg  => 'optimized',
  41     accessor  => 'hand_optimized_type_constraint',
  42     predicate => 'has_hand_optimized_type_constraint',
  43 ));
  44
  45 sub parents {
  46     my $self;
  47     $self->parent;
  48 }
  49
  50 # private accessors
  51
  52 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
  53     accessor  => '_compiled_type_constraint',
  54     predicate => '_has_compiled_type_constraint'
  55 ));
  56 __PACKAGE__->meta->add_attribute('package_defined_in' => (
  57     accessor => '_package_defined_in'
  58 ));
  59
  60 sub new {
  61     my $class = shift;
  62     my ($first, @rest) = @_;
  63     my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
  64     $args{name} = $args{name} ? "$args{name}" : "__ANON__";
  65
  66     my $self  = $class->_new(%args);
  67     $self->compile_type_constraint()
  68         unless $self->_has_compiled_type_constraint;
  69     return $self;
  70 }
  71
  72
  73
  74 sub coerce   { ((shift)->coercion || Moose->throw_error("Cannot coerce without a type coercion"))->coerce(@_) }
  75
  76 sub check {
  77     my ($self, @args) = @_;
  78     my $constraint_subref = $self->_compiled_type_constraint;
  79     return $constraint_subref->(@args) ? 1 : undef;
  80 }
  81
  82 sub validate {
  83     my ($self, $value) = @_;
  84     if ($self->_compiled_type_constraint->($value)) {
  85         return undef;
  86     }
  87     else {
  88         $self->get_message($value);
  89     }
  90 }
  91
  92 sub get_message {
  93     my ($self, $value) = @_;
  94     if (my $msg = $self->message) {
  95         local $_ = $value;
  96         return $msg->($value);
  97     }
  98     else {
  99         $value = (defined $value ? overload::StrVal($value) : 'undef');
 100         return "Validation failed for '" . $self->name . "' failed with value $value";
 101     }
 102 }
 103
 104 ## type predicates ...
 105
 106 sub equals {
 107     my ( $self, $type_or_name ) = @_;
 108
 109     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
 110
 111     return 1 if refaddr($self) == refaddr($other);
 112
 113     if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
 114         return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
 115     }
 116
 117     return unless $self->constraint == $other->constraint;
 118
 119     if ( $self->has_parent ) {
 120         return unless $other->has_parent;
 121         return unless $self->parent->equals( $other->parent );
 122     } else {
 123         return if $other->has_parent;
 124     }
 125
 126     return 1;
 127 }
 128
 129 sub is_a_type_of {
 130     my ($self, $type_or_name) = @_;
 131
 132     my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
 133
 134     ($self->equals($type) || $self->is_subtype_of($type));
 135 }
 136
 137 sub is_subtype_of {
 138     my ($self, $type_or_name) = @_;
 139
 140     my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
 141
 142     my $current = $self;
 143
 144     while (my $parent = $current->parent) {
 145         return 1 if $parent->equals($type);
 146         $current = $parent;
 147     }
 148
 149     return 0;
 150 }
 151
 152 ## compiling the type constraint
 153
 154 sub compile_type_constraint {
 155     my $self = shift;
 156     $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
 157 }
 158
 159 ## type compilers ...
 160
 161 sub _actually_compile_type_constraint {
 162     my $self = shift;
 163
 164     return $self->_compile_hand_optimized_type_constraint
 165         if $self->has_hand_optimized_type_constraint;
 166
 167     my $check = $self->constraint;
 168     (defined $check)
 169         || Moose->throw_error("Could not compile type constraint '"
 170                 . $self->name
 171                 . "' because no constraint check");
 172
 173     return $self->_compile_subtype($check)
 174         if $self->has_parent;
 175
 176     return $self->_compile_type($check);
 177 }
 178
 179 sub _compile_hand_optimized_type_constraint {
 180     my $self = shift;
 181
 182     my $type_constraint = $self->hand_optimized_type_constraint;
 183
 184     Moose->throw_error("Hand optimized type constraint is not a code reference") unless ref $type_constraint;
 185
 186     return $type_constraint;
 187 }
 188
 189 sub _compile_subtype {
 190     my ($self, $check) = @_;
 191
 192     # gather all the parent constraintss in order
 193     my @parents;
 194     my $optimized_parent;
 195     foreach my $parent ($self->_collect_all_parents) {
 196         # if a parent is optimized, the optimized constraint already includes
 197         # all of its parents tcs, so we can break the loop
 198         if ($parent->has_hand_optimized_type_constraint) {
 199             push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
 200             last;
 201         }
 202         else {
 203             push @parents => $parent->constraint;
 204         }
 205     }
 206
 207     @parents = grep { $_ != $null_constraint } reverse @parents;
 208
 209     unless ( @parents ) {
 210         return $self->_compile_type($check);
 211     } elsif( $optimized_parent and @parents == 1 ) {
 212         # the case of just one optimized parent is optimized to prevent
 213         # looping and the unnecessary localization
 214         if ( $check == $null_constraint ) {
 215             return $optimized_parent;
 216         } else {
 217             return Class::MOP::subname($self->name, sub {
 218                 return undef unless $optimized_parent->($_[0]);
 219                 my (@args) = @_;
 220                 local $_ = $args[0];
 221                 $check->(@args);
 222             });
 223         }
 224     } else {
 225         # general case, check all the constraints, from the first parent to ourselves
 226         my @checks = @parents;
 227         push @checks, $check if $check != $null_constraint;
 228         return Class::MOP::subname($self->name => sub {
 229             my (@args) = @_;
 230             local $_ = $args[0];
 231             foreach my $check (@checks) {
 232                 return undef unless $check->(@args);
 233             }
 234             return 1;
 235         });
 236     }
 237 }
 238
 239 sub _compile_type {
 240     my ($self, $check) = @_;
 241
 242     return $check if $check == $null_constraint; # Item, Any
 243
 244     return Class::MOP::subname($self->name => sub {
 245         my (@args) = @_;
 246         local $_ = $args[0];
 247         $check->(@args);
 248     });
 249 }
 250
 251 ## other utils ...
 252
 253 sub _collect_all_parents {
 254     my $self = shift;
 255     my @parents;
 256     my $current = $self->parent;
 257     while (defined $current) {
 258         push @parents => $current;
 259         $current = $current->parent;
 260     }
 261     return @parents;
 262 }
 263
 264 sub create_child_type {
 265     my ($self, %opts) = @_;
 266     my $class = ref $self;
 267     return $class->new(%opts, parent => $self);
 268 }
 269
 270 ## this should get deprecated actually ...
 271
 272 sub union { Carp::croak "DEPRECATED" }
 273
 274 1;
 275
 276 __END__
 277
 278 =pod
 279
 280 =head1 NAME
 281
 282 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
 283
 284 =head1 DESCRIPTION
 285
 286 For the most part, the only time you will ever encounter an
 287 instance of this class is if you are doing some serious deep
 288 introspection. This API should not be considered final, but
 289 it is B<highly unlikely> that this will matter to a regular
 290 Moose user.
 291
 292 If you wish to use features at this depth, please come to the
 293 #moose IRC channel on irc.perl.org and we can talk :)
 294
 295 =head1 METHODS
 296
 297 =over 4
 298
 299 =item B<meta>
 300
 301 =item B<new>
 302
 303 =item B<equals ($type_name_or_object)>
 304
 305 This checks the current type against the supplied type (only).
 306 Returns false if the two types are not equal. It also returns false if
 307 you provide the type as a name, and the type name isn't found in the
 308 type registry.
 309
 310 =item B<is_a_type_of ($type_name_or_object)>
 311
 312 This checks the current type against the supplied type, or if the
 313 current type is a sub-type of the type name or object supplied. It
 314 also returns false if you provide the type as a name, and the type
 315 name isn't found in the type registry.
 316
 317 =item B<is_subtype_of ($type_name_or_object)>
 318
 319 This checks the current type is a sub-type of the type name or object
 320 supplied. It also returns false if you provide the type as a name, and
 321 the type name isn't found in the type registry.
 322
 323 =item B<compile_type_constraint>
 324
 325 =item B<coerce ($value)>
 326
 327 This will apply the type-coercion if applicable.
 328
 329 =item B<check ($value)>
 330
 331 This method will return a true (C<1>) if the C<$value> passes the
 332 constraint, and false (C<0>) otherwise.
 333
 334 =item B<validate ($value)>
 335
 336 This method is similar to C<check>, but it deals with the error
 337 message. If the C<$value> passes the constraint, C<undef> will be
 338 returned. If the C<$value> does B<not> pass the constraint, then
 339 the C<message> will be used to construct a custom error message.
 340
 341 =item B<name>
 342
 343 The name of the type in the global type registry.
 344
 345 =item B<parent>
 346
 347 This type's parent type.
 348
 349 =item B<has_parent>
 350
 351 Returns true if this type has a parent type.
 352
 353 =item B<parents>
 354
 355 Synonym for C<parent>.
 356
 357 =item B<constraint>
 358
 359 Returns this type's constraint.  This is the value of C<where> provided
 360 when defining a type.
 361
 362 =item B<has_message>
 363
 364 Returns true if this type has a message.
 365
 366 =item B<message>
 367
 368 Returns this type's message.
 369
 370 =item B<get_message ($value)>
 371
 372 Generate message for $value.
 373
 374 =item B<has_coercion>
 375
 376 Returns true if this type has a coercion.
 377
 378 =item B<coercion>
 379
 380 Returns this type's L<Moose::Meta::TypeCoercion> if one exists.
 381
 382 =item B<hand_optimized_type_constraint>
 383
 384 =item B<has_hand_optimized_type_constraint>
 385
 386 =item B<create_child_type>
 387
 388 =back
 389
 390 =head2 DEPRECATED METHOD
 391
 392 =over 4
 393
 394 =item B<union>
 395
 396 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
 397 itself instead.
 398
 399 =back
 400
 401 =head1 BUGS
 402
 403 All complex software has bugs lurking in it, and this module is no
 404 exception. If you find a bug please either email me, or add the bug
 405 to cpan-RT.
 406
 407 =head1 AUTHOR
 408
 409 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 410
 411 =head1 COPYRIGHT AND LICENSE
 412
 413 Copyright 2006-2009 by Infinity Interactive, Inc.
 414
 415 L<http://www.iinteractive.com>
 416
 417 This library is free software; you can redistribute it and/or modify
 418 it under the same terms as Perl itself.
 419
 420 =cut