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 use Scalar::Util 'blessed';
  11
  12 our $VERSION = '0.03';
  13
  14 __PACKAGE__->meta->add_attribute('name'       => (reader => 'name'      ));
  15 __PACKAGE__->meta->add_attribute('parent'     => (reader => 'parent'    ));
  16 __PACKAGE__->meta->add_attribute('constraint' => (reader => 'constraint'));
  17 __PACKAGE__->meta->add_attribute('message'   => (
  18     accessor  => 'message',
  19     predicate => 'has_message'
  20 ));
  21 __PACKAGE__->meta->add_attribute('coercion'   => (
  22     accessor  => 'coercion',
  23     predicate => 'has_coercion'
  24 ));
  25
  26 # private accessor
  27 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
  28     accessor => '_compiled_type_constraint'
  29 ));
  30
  31 sub new {
  32     my $class = shift;
  33     my $self  = $class->meta->new_object(@_);
  34     $self->compile_type_constraint();
  35     return $self;
  36 }
  37
  38 sub compile_type_constraint {
  39     my $self  = shift;
  40     my $check = $self->constraint;
  41     (defined $check)
  42         || confess "Could not compile type constraint '" . $self->name . "' because no constraint check";
  43     my $parent = $self->parent;
  44     if (defined $parent) {
  45         # we have a subtype ...
  46         $parent = $parent->_compiled_type_constraint;
  47                 $self->_compiled_type_constraint(subname $self->name => sub {
  48                         local $_ = $_[0];
  49                         return undef unless defined $parent->($_[0]) && $check->($_[0]);
  50                         1;
  51                 });
  52     }
  53     else {
  54         # we have a type ....
  55         $self->_compiled_type_constraint(subname $self->name => sub {
  56                 local $_ = $_[0];
  57                 return undef unless $check->($_[0]);
  58                 1;
  59         });
  60     }
  61 }
  62
  63 sub check { $_[0]->_compiled_type_constraint->($_[1]) }
  64
  65 sub validate {
  66     my ($self, $value) = @_;
  67     if ($self->_compiled_type_constraint->($value)) {
  68         return undef;
  69     }
  70     else {
  71         if ($self->has_message) {
  72             local $_ = $value;
  73             return $self->message->($value);
  74         }
  75         else {
  76             return "Validation failed for '" . $self->name . "' failed";
  77         }
  78     }
  79 }
  80
  81 sub is_subtype_of {
  82     my ($self, $type_name) = @_;
  83     my $current = $self;
  84     while (my $parent = $current->parent) {
  85         return 1 if $parent->name eq $type_name;
  86         $current = $parent;
  87     }
  88     return 0;
  89 }
  90
  91 sub union {
  92     my ($class, @type_constraints) = @_;
  93     (scalar @type_constraints >= 2)
  94         || confess "You must pass in at least 2 Moose::Meta::TypeConstraint instances to make a union";
  95     (blessed($_) && $_->isa('Moose::Meta::TypeConstraint'))
  96         || confess "You must pass in only Moose::Meta::TypeConstraint instances to make unions"
  97             foreach @type_constraints;
  98     return Moose::Meta::TypeConstraint::Union->new(
  99         type_constraints => \@type_constraints
 100     );
 101 }
 102
 103 package Moose::Meta::TypeConstraint::Union;
 104
 105 use strict;
 106 use warnings;
 107 use metaclass;
 108
 109 our $VERSION = '0.01';
 110
 111 __PACKAGE__->meta->add_attribute('type_constraints' => (
 112     accessor  => 'type_constraints',
 113     default   => sub { [] }
 114 ));
 115
 116 sub new {
 117     my $class = shift;
 118     my $self  = $class->meta->new_object(@_);
 119     return $self;
 120 }
 121
 122 sub name { join ' | ' => map { $_->name } @{$_[0]->type_constraints} }
 123
 124 # NOTE:
 125 # this should probably never be used
 126 # but we include it here for completeness
 127 sub constraint    {
 128     my $self = shift;
 129     sub { $self->check($_[0]) };
 130 }
 131
 132 # conform to the TypeConstraint API
 133 sub parent        { undef  }
 134 sub coercion      { undef  }
 135 sub has_coercion  { 0      }
 136 sub message       { undef  }
 137 sub has_message   { 0      }
 138
 139 sub check {
 140     my $self  = shift;
 141     my $value = shift;
 142     foreach my $type (@{$self->type_constraints}) {
 143         return 1 if $type->check($value);
 144     }
 145     return undef;
 146 }
 147
 148 sub validate {
 149     my $self  = shift;
 150     my $value = shift;
 151     my $message;
 152     foreach my $type (@{$self->type_constraints}) {
 153         my $err = $type->validate($value);
 154         return unless defined $err;
 155         $message .= ($message ? ' and ' : '') . $err
 156             if defined $err;
 157     }
 158     return ($message . ' in (' . $self->name . ')') ;
 159 }
 160
 161 1;
 162
 163 __END__
 164
 165 =pod
 166
 167 =head1 NAME
 168
 169 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
 170
 171 =head1 DESCRIPTION
 172
 173 For the most part, the only time you will ever encounter an
 174 instance of this class is if you are doing some serious deep
 175 introspection. This API should not be considered final, but
 176 it is B<highly unlikely> that this will matter to a regular
 177 Moose user.
 178
 179 If you wish to use features at this depth, please come to the
 180 #moose IRC channel on irc.perl.org and we can talk :)
 181
 182 =head1 METHODS
 183
 184 =over 4
 185
 186 =item B<meta>
 187
 188 =item B<new>
 189
 190 =item B<is_subtype_of>
 191
 192 =item B<compile_type_constraint>
 193
 194 =item B<check ($value)>
 195
 196 This method will return a true (C<1>) if the C<$value> passes the
 197 constraint, and false (C<0>) otherwise.
 198
 199 =item B<validate ($value)>
 200
 201 This method is similar to C<check>, but it deals with the error
 202 message. If the C<$value> passes the constraint, C<undef> will be
 203 returned. If the C<$value> does B<not> pass the constraint, then
 204 the C<message> will be used to construct a custom error message.
 205
 206 =item B<name>
 207
 208 =item B<parent>
 209
 210 =item B<constraint>
 211
 212 =item B<has_message>
 213
 214 =item B<message>
 215
 216 =item B<has_coercion>
 217
 218 =item B<coercion>
 219
 220 =back
 221
 222 =over 4
 223
 224 =item B<union (@type_constraints)>
 225
 226 =back
 227
 228 =head1 BUGS
 229
 230 All complex software has bugs lurking in it, and this module is no
 231 exception. If you find a bug please either email me, or add the bug
 232 to cpan-RT.
 233
 234 =head1 AUTHOR
 235
 236 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 237
 238 =head1 COPYRIGHT AND LICENSE
 239
 240 Copyright 2006 by Infinity Interactive, Inc.
 241
 242 L<http://www.iinteractive.com>
 243
 244 This library is free software; you can redistribute it and/or modify
 245 it under the same terms as Perl itself.
 246
 247 =cut