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