lib/Moose/Meta/TypeConstraint.pm

   1
   2 package Moose::Meta::TypeConstraint;
   3
   4 use strict;
   5 use warnings;
   6 use metaclass;
   7
   8 use Sub::Name    'subname';
   9 use Carp         'confess';
  10 use Scalar::Util 'blessed';
  11
  12 our $VERSION = '0.06';
  13
  14 use Moose::Meta::TypeConstraint::Union;
  15
  16 __PACKAGE__->meta->add_attribute('name'       => (reader => 'name'      ));
  17 __PACKAGE__->meta->add_attribute('parent'     => (reader => 'parent'    ));
  18 __PACKAGE__->meta->add_attribute('constraint' => (reader => 'constraint'));
  19 __PACKAGE__->meta->add_attribute('message'   => (
  20     accessor  => 'message',
  21     predicate => 'has_message'
  22 ));
  23 __PACKAGE__->meta->add_attribute('coercion'   => (
  24     accessor  => 'coercion',
  25     predicate => 'has_coercion'
  26 ));
  27
  28 # private accessor
  29 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
  30     accessor => '_compiled_type_constraint'
  31 ));
  32
  33 __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
  34     init_arg  => 'optimized',
  35     accessor  => 'hand_optimized_type_constraint',
  36     predicate => 'has_hand_optimized_type_constraint',
  37 ));
  38
  39 sub new {
  40     my $class = shift;
  41     my $self  = $class->meta->new_object(@_);
  42     $self->compile_type_constraint();
  43     return $self;
  44 }
  45
  46 sub coerce {
  47     ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_)
  48 }
  49
  50 sub _collect_all_parents {
  51     my $self = shift;
  52     my @parents;
  53     my $current = $self->parent;
  54     while (defined $current) {
  55         push @parents => $current;
  56         $current = $current->parent;
  57     }
  58     return @parents;
  59 }
  60
  61 sub compile_type_constraint {
  62     my $self  = shift;
  63
  64     if ($self->has_hand_optimized_type_constraint) {
  65         my $type_constraint = $self->hand_optimized_type_constraint;
  66         $self->_compiled_type_constraint(sub {
  67             return undef unless $type_constraint->($_[0]);
  68             return 1;
  69         });
  70         return;
  71     }
  72
  73     my $check = $self->constraint;
  74     (defined $check)
  75         || confess "Could not compile type constraint '" . $self->name . "' because no constraint check";
  76     my $parent = $self->parent;
  77     if (defined $parent) {
  78         # we have a subtype ...
  79         # so we gather all the parents in order
  80         # and grab their constraints ...
  81         my @parents;
  82         foreach my $parent ($self->_collect_all_parents) {
  83             if ($parent->has_hand_optimized_type_constraint) {
  84                 unshift @parents => $parent->hand_optimized_type_constraint;
  85                 last;
  86             }
  87             else {
  88                 unshift @parents => $parent->constraint;
  89             }
  90         }
  91
  92         # then we compile them to run without
  93         # having to recurse as we did before
  94                 $self->_compiled_type_constraint(subname $self->name => sub {
  95                         local $_ = $_[0];
  96             foreach my $parent (@parents) {
  97                 return undef unless $parent->($_[0]);
  98             }
  99                         return undef unless $check->($_[0]);
 100                         1;
 101                 });
 102     }
 103     else {
 104         # we have a type ....
 105         $self->_compiled_type_constraint(subname $self->name => sub {
 106                 local $_ = $_[0];
 107                 return undef unless $check->($_[0]);
 108                 1;
 109         });
 110     }
 111 }
 112
 113 sub check { $_[0]->_compiled_type_constraint->($_[1]) }
 114
 115 sub validate {
 116     my ($self, $value) = @_;
 117     if ($self->_compiled_type_constraint->($value)) {
 118         return undef;
 119     }
 120     else {
 121         if ($self->has_message) {
 122             local $_ = $value;
 123             return $self->message->($value);
 124         }
 125         else {
 126             return "Validation failed for '" . $self->name . "' failed";
 127         }
 128     }
 129 }
 130
 131 sub is_a_type_of {
 132     my ($self, $type_name) = @_;
 133     ($self->name eq $type_name || $self->is_subtype_of($type_name));
 134 }
 135
 136 sub is_subtype_of {
 137     my ($self, $type_name) = @_;
 138     my $current = $self;
 139     while (my $parent = $current->parent) {
 140         return 1 if $parent->name eq $type_name;
 141         $current = $parent;
 142     }
 143     return 0;
 144 }
 145
 146 sub union {
 147     my ($class, @type_constraints) = @_;
 148     (scalar @type_constraints >= 2)
 149         || confess "You must pass in at least 2 Moose::Meta::TypeConstraint instances to make a union";
 150     (blessed($_) && $_->isa('Moose::Meta::TypeConstraint'))
 151         || confess "You must pass in only Moose::Meta::TypeConstraint instances to make unions"
 152             foreach @type_constraints;
 153     return Moose::Meta::TypeConstraint::Union->new(
 154         type_constraints => \@type_constraints,
 155     );
 156 }
 157
 158 1;
 159
 160 __END__
 161
 162 =pod
 163
 164 =head1 NAME
 165
 166 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
 167
 168 =head1 DESCRIPTION
 169
 170 For the most part, the only time you will ever encounter an
 171 instance of this class is if you are doing some serious deep
 172 introspection. This API should not be considered final, but
 173 it is B<highly unlikely> that this will matter to a regular
 174 Moose user.
 175
 176 If you wish to use features at this depth, please come to the
 177 #moose IRC channel on irc.perl.org and we can talk :)
 178
 179 =head1 METHODS
 180
 181 =over 4
 182
 183 =item B<meta>
 184
 185 =item B<new>
 186
 187 =item B<is_a_type_of ($type_name)>
 188
 189 This checks the current type name, and if it does not match,
 190 checks if it is a subtype of it.
 191
 192 =item B<is_subtype_of ($type_name)>
 193
 194 =item B<compile_type_constraint>
 195
 196 =item B<coerce ($value)>
 197
 198 This will apply the type-coercion if applicable.
 199
 200 =item B<check ($value)>
 201
 202 This method will return a true (C<1>) if the C<$value> passes the
 203 constraint, and false (C<0>) otherwise.
 204
 205 =item B<validate ($value)>
 206
 207 This method is similar to C<check>, but it deals with the error
 208 message. If the C<$value> passes the constraint, C<undef> will be
 209 returned. If the C<$value> does B<not> pass the constraint, then
 210 the C<message> will be used to construct a custom error message.
 211
 212 =item B<name>
 213
 214 =item B<parent>
 215
 216 =item B<constraint>
 217
 218 =item B<has_message>
 219
 220 =item B<message>
 221
 222 =item B<has_coercion>
 223
 224 =item B<coercion>
 225
 226 =item B<hand_optimized_type_constraint>
 227
 228 =item B<has_hand_optimized_type_constraint>
 229
 230 =back
 231
 232 =over 4
 233
 234 =item B<union (@type_constraints)>
 235
 236 =back
 237
 238 =head1 BUGS
 239
 240 All complex software has bugs lurking in it, and this module is no
 241 exception. If you find a bug please either email me, or add the bug
 242 to cpan-RT.
 243
 244 =head1 AUTHOR
 245
 246 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 247
 248 =head1 COPYRIGHT AND LICENSE
 249
 250 Copyright 2006 by Infinity Interactive, Inc.
 251
 252 L<http://www.iinteractive.com>
 253
 254 This library is free software; you can redistribute it and/or modify
 255 it under the same terms as Perl itself.
 256
 257 =cut