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