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