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.05';
  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 coerce {
  39     ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_)
  40 }
  41
  42 sub compile_type_constraint {
  43     my $self  = shift;
  44     my $check = $self->constraint;
  45     (defined $check)
  46         || confess "Could not compile type constraint '" . $self->name . "' because no constraint check";
  47     my $parent = $self->parent;
  48     if (defined $parent) {
  49         # we have a subtype ...
  50         $parent = $parent->_compiled_type_constraint;
  51                 $self->_compiled_type_constraint(subname $self->name => sub {
  52                         local $_ = $_[0];
  53                         return undef unless defined $parent->($_[0]) && $check->($_[0]);
  54                         1;
  55                 });
  56     }
  57     else {
  58         # we have a type ....
  59         $self->_compiled_type_constraint(subname $self->name => sub {
  60                 local $_ = $_[0];
  61                 return undef unless $check->($_[0]);
  62                 1;
  63         });
  64     }
  65 }
  66
  67 sub check { $_[0]->_compiled_type_constraint->($_[1]) }
  68
  69 sub validate {
  70     my ($self, $value) = @_;
  71     if ($self->_compiled_type_constraint->($value)) {
  72         return undef;
  73     }
  74     else {
  75         if ($self->has_message) {
  76             local $_ = $value;
  77             return $self->message->($value);
  78         }
  79         else {
  80             return "Validation failed for '" . $self->name . "' failed";
  81         }
  82     }
  83 }
  84
  85 sub is_a_type_of {
  86     my ($self, $type_name) = @_;
  87     ($self->name eq $type_name || $self->is_subtype_of($type_name));
  88 }
  89
  90 sub is_subtype_of {
  91     my ($self, $type_name) = @_;
  92     my $current = $self;
  93     while (my $parent = $current->parent) {
  94         return 1 if $parent->name eq $type_name;
  95         $current = $parent;
  96     }
  97     return 0;
  98 }
  99
 100 sub union {
 101     my ($class, @type_constraints) = @_;
 102     (scalar @type_constraints >= 2)
 103         || confess "You must pass in at least 2 Moose::Meta::TypeConstraint instances to make a union";
 104     (blessed($_) && $_->isa('Moose::Meta::TypeConstraint'))
 105         || confess "You must pass in only Moose::Meta::TypeConstraint instances to make unions"
 106             foreach @type_constraints;
 107     return Moose::Meta::TypeConstraint::Union->new(
 108         type_constraints => \@type_constraints,
 109     );
 110 }
 111
 112 package Moose::Meta::TypeConstraint::Union;
 113
 114 use strict;
 115 use warnings;
 116 use metaclass;
 117
 118 our $VERSION = '0.02';
 119
 120 __PACKAGE__->meta->add_attribute('type_constraints' => (
 121     accessor  => 'type_constraints',
 122     default   => sub { [] }
 123 ));
 124
 125 sub new {
 126     my $class = shift;
 127     my $self  = $class->meta->new_object(@_);
 128     return $self;
 129 }
 130
 131 sub name { join ' | ' => map { $_->name } @{$_[0]->type_constraints} }
 132
 133 # NOTE:
 134 # this should probably never be used
 135 # but we include it here for completeness
 136 sub constraint    {
 137     my $self = shift;
 138     sub { $self->check($_[0]) };
 139 }
 140
 141 # conform to the TypeConstraint API
 142 sub parent        { undef  }
 143 sub message       { undef  }
 144 sub has_message   { 0      }
 145
 146 # FIXME:
 147 # not sure what this should actually do here
 148 sub coercion { undef  }
 149
 150 # this should probably be memoized
 151 sub has_coercion  {
 152     my $self  = shift;
 153     foreach my $type (@{$self->type_constraints}) {
 154         return 1 if $type->has_coercion
 155     }
 156     return 0;
 157 }
 158
 159 # NOTE:
 160 # this feels too simple, and may not always DWIM
 161 # correctly, especially in the presence of
 162 # close subtype relationships, however it should
 163 # work for a fair percentage of the use cases
 164 sub coerce {
 165     my $self  = shift;
 166     my $value = shift;
 167     foreach my $type (@{$self->type_constraints}) {
 168         if ($type->has_coercion) {
 169             my $temp = $type->coerce($value);
 170             return $temp if $self->check($temp);
 171         }
 172     }
 173     return undef;
 174 }
 175
 176 sub check {
 177     my $self  = shift;
 178     my $value = shift;
 179     foreach my $type (@{$self->type_constraints}) {
 180         return 1 if $type->check($value);
 181     }
 182     return undef;
 183 }
 184
 185 sub validate {
 186     my $self  = shift;
 187     my $value = shift;
 188     my $message;
 189     foreach my $type (@{$self->type_constraints}) {
 190         my $err = $type->validate($value);
 191         return unless defined $err;
 192         $message .= ($message ? ' and ' : '') . $err
 193             if defined $err;
 194     }
 195     return ($message . ' in (' . $self->name . ')') ;
 196 }
 197
 198 sub is_a_type_of {
 199     my ($self, $type_name) = @_;
 200     foreach my $type (@{$self->type_constraints}) {
 201         return 1 if $type->is_a_type_of($type_name);
 202     }
 203     return 0;
 204 }
 205
 206 sub is_subtype_of {
 207     my ($self, $type_name) = @_;
 208     foreach my $type (@{$self->type_constraints}) {
 209         return 1 if $type->is_subtype_of($type_name);
 210     }
 211     return 0;
 212 }
 213
 214 1;
 215
 216 __END__
 217
 218 =pod
 219
 220 =head1 NAME
 221
 222 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
 223
 224 =head1 DESCRIPTION
 225
 226 For the most part, the only time you will ever encounter an
 227 instance of this class is if you are doing some serious deep
 228 introspection. This API should not be considered final, but
 229 it is B<highly unlikely> that this will matter to a regular
 230 Moose user.
 231
 232 If you wish to use features at this depth, please come to the
 233 #moose IRC channel on irc.perl.org and we can talk :)
 234
 235 =head1 METHODS
 236
 237 =over 4
 238
 239 =item B<meta>
 240
 241 =item B<new>
 242
 243 =item B<is_a_type_of ($type_name)>
 244
 245 This checks the current type name, and if it does not match,
 246 checks if it is a subtype of it.
 247
 248 =item B<is_subtype_of ($type_name)>
 249
 250 =item B<compile_type_constraint>
 251
 252 =item B<coerce ($value)>
 253
 254 This will apply the type-coercion if applicable.
 255
 256 =item B<check ($value)>
 257
 258 This method will return a true (C<1>) if the C<$value> passes the
 259 constraint, and false (C<0>) otherwise.
 260
 261 =item B<validate ($value)>
 262
 263 This method is similar to C<check>, but it deals with the error
 264 message. If the C<$value> passes the constraint, C<undef> will be
 265 returned. If the C<$value> does B<not> pass the constraint, then
 266 the C<message> will be used to construct a custom error message.
 267
 268 =item B<name>
 269
 270 =item B<parent>
 271
 272 =item B<constraint>
 273
 274 =item B<has_message>
 275
 276 =item B<message>
 277
 278 =item B<has_coercion>
 279
 280 =item B<coercion>
 281
 282 =back
 283
 284 =over 4
 285
 286 =item B<union (@type_constraints)>
 287
 288 =back
 289
 290 =head1 BUGS
 291
 292 All complex software has bugs lurking in it, and this module is no
 293 exception. If you find a bug please either email me, or add the bug
 294 to cpan-RT.
 295
 296 =head1 AUTHOR
 297
 298 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 299
 300 =head1 COPYRIGHT AND LICENSE
 301
 302 Copyright 2006 by Infinity Interactive, Inc.
 303
 304 L<http://www.iinteractive.com>
 305
 306 This library is free software; you can redistribute it and/or modify
 307 it under the same terms as Perl itself.
 308
 309 =cut