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.11';
  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]) ? 1 : undef }
  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     confess unless ref $type_constraint;
 128
 129     return $type_constraint;
 130 }
 131
 132 sub _compile_subtype {
 133     my ($self, $check) = @_;
 134
 135     # so we gather all the parents in order
 136     # and grab their constraints ...
 137     my @parents;
 138     foreach my $parent ($self->_collect_all_parents) {
 139         if ($parent->has_hand_optimized_type_constraint) {
 140             unshift @parents => $parent->hand_optimized_type_constraint;
 141             last;
 142         }
 143         else {
 144             unshift @parents => $parent->constraint;
 145         }
 146     }
 147
 148     # then we compile them to run without
 149     # having to recurse as we did before
 150     return subname $self->name => sub {
 151         local $_ = $_[0];
 152         foreach my $parent (@parents) {
 153             return undef unless $parent->($_[0]);
 154         }
 155         return undef unless $check->($_[0]);
 156         1;
 157     };
 158 }
 159
 160 sub _compile_type {
 161     my ($self, $check) = @_;
 162     return subname $self->name => sub {
 163         local $_ = $_[0];
 164         return undef unless $check->($_[0]);
 165         1;
 166     };
 167 }
 168
 169 ## other utils ...
 170
 171 sub _collect_all_parents {
 172     my $self = shift;
 173     my @parents;
 174     my $current = $self->parent;
 175     while (defined $current) {
 176         push @parents => $current;
 177         $current = $current->parent;
 178     }
 179     return @parents;
 180 }
 181
 182 ## this should get deprecated actually ...
 183
 184 sub union { die "DEPRECATED" }
 185
 186 1;
 187
 188 __END__
 189
 190 =pod
 191
 192 =head1 NAME
 193
 194 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
 195
 196 =head1 DESCRIPTION
 197
 198 For the most part, the only time you will ever encounter an
 199 instance of this class is if you are doing some serious deep
 200 introspection. This API should not be considered final, but
 201 it is B<highly unlikely> that this will matter to a regular
 202 Moose user.
 203
 204 If you wish to use features at this depth, please come to the
 205 #moose IRC channel on irc.perl.org and we can talk :)
 206
 207 =head1 METHODS
 208
 209 =over 4
 210
 211 =item B<meta>
 212
 213 =item B<new>
 214
 215 =item B<is_a_type_of ($type_name)>
 216
 217 This checks the current type name, and if it does not match,
 218 checks if it is a subtype of it.
 219
 220 =item B<is_subtype_of ($type_name)>
 221
 222 =item B<compile_type_constraint>
 223
 224 =item B<coerce ($value)>
 225
 226 This will apply the type-coercion if applicable.
 227
 228 =item B<check ($value)>
 229
 230 This method will return a true (C<1>) if the C<$value> passes the
 231 constraint, and false (C<0>) otherwise.
 232
 233 =item B<validate ($value)>
 234
 235 This method is similar to C<check>, but it deals with the error
 236 message. If the C<$value> passes the constraint, C<undef> will be
 237 returned. If the C<$value> does B<not> pass the constraint, then
 238 the C<message> will be used to construct a custom error message.
 239
 240 =item B<name>
 241
 242 =item B<parent>
 243
 244 =item B<has_parent>
 245
 246 =item B<constraint>
 247
 248 =item B<has_message>
 249
 250 =item B<message>
 251
 252 =item B<has_coercion>
 253
 254 =item B<coercion>
 255
 256 =item B<hand_optimized_type_constraint>
 257
 258 =item B<has_hand_optimized_type_constraint>
 259
 260 =back
 261
 262 =head2 DEPRECATED METHOD
 263
 264 =over 4
 265
 266 =item B<union>
 267
 268 This was just bad idea on my part,.. use the L<Moose::Meta::TypeConstraint::Union>
 269 itself instead.
 270
 271 =back
 272
 273 =head1 BUGS
 274
 275 All complex software has bugs lurking in it, and this module is no
 276 exception. If you find a bug please either email me, or add the bug
 277 to cpan-RT.
 278
 279 =head1 AUTHOR
 280
 281 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 282
 283 =head1 COPYRIGHT AND LICENSE
 284
 285 Copyright 2006-2008 by Infinity Interactive, Inc.
 286
 287 L<http://www.iinteractive.com>
 288
 289 This library is free software; you can redistribute it and/or modify
 290 it under the same terms as Perl itself.
 291
 292 =cut