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