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.03';
  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                         1;
  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                 1;
  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 sub union {
  81     my ($class, @type_constraints) = @_;
  82     return Moose::Meta::TypeConstraint::Union->new(
  83         type_constraints => \@type_constraints
  84     );
  85 }
  86
  87 package Moose::Meta::TypeConstraint::Union;
  88
  89 use strict;
  90 use warnings;
  91 use metaclass;
  92
  93 our $VERSION = '0.01';
  94
  95 __PACKAGE__->meta->add_attribute('type_constraints' => (
  96     accessor  => 'type_constraints',
  97     default   => sub { [] }
  98 ));
  99
 100 sub new {
 101     my $class = shift;
 102     my $self  = $class->meta->new_object(@_);
 103     return $self;
 104 }
 105
 106 sub name { join ' | ' => map { $_->name } @{$_[0]->type_constraints} }
 107
 108 sub check {
 109     my $self  = shift;
 110     my $value = shift;
 111     foreach my $type (@{$self->type_constraints}) {
 112         return 1 if $type->check($value);
 113     }
 114     return undef;
 115 }
 116
 117 sub validate {
 118     my $self  = shift;
 119     my $value = shift;
 120     my $message;
 121     foreach my $type (@{$self->type_constraints}) {
 122         my $err = $type->validate($value);
 123         return unless defined $err;
 124         $message .= ($message ? ' and ' : '') . $err
 125             if defined $err;
 126     }
 127     return ($message . ' in (' . $self->name . ')') ;
 128 }
 129
 130 1;
 131
 132 __END__
 133
 134 =pod
 135
 136 =head1 NAME
 137
 138 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
 139
 140 =head1 DESCRIPTION
 141
 142 For the most part, the only time you will ever encounter an
 143 instance of this class is if you are doing some serious deep
 144 introspection. This API should not be considered final, but
 145 it is B<highly unlikely> that this will matter to a regular
 146 Moose user.
 147
 148 If you wish to use features at this depth, please come to the
 149 #moose IRC channel on irc.perl.org and we can talk :)
 150
 151 =head1 METHODS
 152
 153 =over 4
 154
 155 =item B<meta>
 156
 157 =item B<new>
 158
 159 =item B<compile_type_constraint>
 160
 161 =item B<check ($value)>
 162
 163 This method will return a true (C<1>) if the C<$value> passes the
 164 constraint, and false (C<0>) otherwise.
 165
 166 =item B<validate ($value)>
 167
 168 This method is similar to C<check>, but it deals with the error
 169 message. If the C<$value> passes the constraint, C<undef> will be
 170 returned. If the C<$value> does B<not> pass the constraint, then
 171 the C<message> will be used to construct a custom error message.
 172
 173 =item B<name>
 174
 175 =item B<parent>
 176
 177 =item B<constraint>
 178
 179 =item B<has_message>
 180
 181 =item B<message>
 182
 183 =item B<has_coercion>
 184
 185 =item B<coercion>
 186
 187 =back
 188
 189 =over 4
 190
 191 =item B<union (@type_constraints)>
 192
 193 =back
 194
 195 =head1 BUGS
 196
 197 All complex software has bugs lurking in it, and this module is no
 198 exception. If you find a bug please either email me, or add the bug
 199 to cpan-RT.
 200
 201 =head1 AUTHOR
 202
 203 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 204
 205 =head1 COPYRIGHT AND LICENSE
 206
 207 Copyright 2006 by Infinity Interactive, Inc.
 208
 209 L<http://www.iinteractive.com>
 210
 211 This library is free software; you can redistribute it and/or modify
 212 it under the same terms as Perl itself.
 213
 214 =cut