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