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