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