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