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
  11 our $VERSION = '0.02';
  12
  13 __PACKAGE__->meta->add_attribute('name'       => (reader => 'name'      ));
  14 __PACKAGE__->meta->add_attribute('parent'     => (reader => 'parent'    ));
  15 __PACKAGE__->meta->add_attribute('constraint' => (reader => 'constraint'));
  16 __PACKAGE__->meta->add_attribute('message'   => (
  17     accessor  => 'message',
  18     predicate => 'has_message'
  19 ));
  20 __PACKAGE__->meta->add_attribute('coercion'   => (
  21     accessor  => 'coercion',
  22     predicate => 'has_coercion'
  23 ));
  24
  25 # private accessor
  26 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
  27     accessor => '_compiled_type_constraint'
  28 ));
  29
  30 sub new {
  31     my $class = shift;
  32     my $self  = $class->meta->new_object(@_);
  33     $self->compile_type_constraint();
  34     return $self;
  35 }
  36
  37 sub compile_type_constraint () {
  38     my $self  = shift;
  39     my $check = $self->constraint;
  40     (defined $check)
  41         || confess "Could not compile type constraint '" . $self->name . "' because no constraint check";
  42     my $parent = $self->parent;
  43     if (defined $parent) {
  44         # we have a subtype ...
  45         $parent = $parent->_compiled_type_constraint;
  46                 $self->_compiled_type_constraint(subname $self->name => sub {
  47                         local $_ = $_[0];
  48                         return undef unless defined $parent->($_[0]) && $check->($_[0]);
  49                         $_[0];
  50                 });
  51     }
  52     else {
  53         # we have a type ....
  54         $self->_compiled_type_constraint(subname $self->name => sub {
  55                 local $_ = $_[0];
  56                 return undef unless $check->($_[0]);
  57                 $_[0];
  58         });
  59     }
  60 }
  61
  62 sub check { $_[0]->_compiled_type_constraint->($_[1]) }
  63
  64 sub validate {
  65     my ($self, $value) = @_;
  66     if ($self->_compiled_type_constraint->($value)) {
  67         return undef;
  68     }
  69     else {
  70         if ($self->has_message) {
  71             local $_ = $value;
  72             return $self->message->($value);
  73         }
  74         else {
  75             return "Validation failed for '" . $self->name . "' failed.";
  76         }
  77     }
  78 }
  79
  80 1;
  81
  82 __END__
  83
  84 =pod
  85
  86 =head1 NAME
  87
  88 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
  89
  90 =head1 DESCRIPTION
  91
  92 For the most part, the only time you will ever encounter an
  93 instance of this class is if you are doing some serious deep
  94 introspection. This API should not be considered final, but
  95 it is B<highly unlikely> that this will matter to a regular
  96 Moose user.
  97
  98 If you wish to use features at this depth, please come to the
  99 #moose IRC channel on irc.perl.org and we can talk :)
 100
 101 =head1 METHODS
 102
 103 =over 4
 104
 105 =item B<meta>
 106
 107 =item B<new>
 108
 109 =item B<compile_type_constraint>
 110
 111 =item B<check ($value)>
 112
 113 This method will return a true (C<1>) if the C<$value> passes the
 114 constraint, and false (C<0>) otherwise.
 115
 116 =item B<validate ($value)>
 117
 118 This method is similar to C<check>, but it deals with the error
 119 message. If the C<$value> passes the constraint, C<undef> will be
 120 returned. If the C<$value> does B<not> pass the constraint, then
 121 the C<message> will be used to construct a custom error message.
 122
 123 =item B<name>
 124
 125 =item B<parent>
 126
 127 =item B<constraint>
 128
 129 =item B<has_message>
 130
 131 =item B<message>
 132
 133 =item B<has_coercion>
 134
 135 =item B<coercion>
 136
 137 =back
 138
 139 =head1 BUGS
 140
 141 All complex software has bugs lurking in it, and this module is no
 142 exception. If you find a bug please either email me, or add the bug
 143 to cpan-RT.
 144
 145 =head1 AUTHOR
 146
 147 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 148
 149 =head1 COPYRIGHT AND LICENSE
 150
 151 Copyright 2006 by Infinity Interactive, Inc.
 152
 153 L<http://www.iinteractive.com>
 154
 155 This library is free software; you can redistribute it and/or modify
 156 it under the same terms as Perl itself.
 157
 158 =cut