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