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