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