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