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.04';
  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_a_type_of {
  82     my ($self, $type_name) = @_;
  83     ($self->name eq $type_name || $self->is_subtype_of($type_name));
  84 }
  85
  86 sub is_subtype_of {
  87     my ($self, $type_name) = @_;
  88     my $current = $self;
  89     while (my $parent = $current->parent) {
  90         return 1 if $parent->name eq $type_name;
  91         $current = $parent;
  92     }
  93     return 0;
  94 }
  95
  96 sub union {
  97     my ($class, @type_constraints) = @_;
  98     (scalar @type_constraints >= 2)
  99         || confess "You must pass in at least 2 Moose::Meta::TypeConstraint instances to make a union";
 100     (blessed($_) && $_->isa('Moose::Meta::TypeConstraint'))
 101         || confess "You must pass in only Moose::Meta::TypeConstraint instances to make unions"
 102             foreach @type_constraints;
 103     return Moose::Meta::TypeConstraint::Union->new(
 104         type_constraints => \@type_constraints
 105     );
 106 }
 107
 108 package Moose::Meta::TypeConstraint::Union;
 109
 110 use strict;
 111 use warnings;
 112 use metaclass;
 113
 114 our $VERSION = '0.01';
 115
 116 __PACKAGE__->meta->add_attribute('type_constraints' => (
 117     accessor  => 'type_constraints',
 118     default   => sub { [] }
 119 ));
 120
 121 sub new {
 122     my $class = shift;
 123     my $self  = $class->meta->new_object(@_);
 124     return $self;
 125 }
 126
 127 sub name { join ' | ' => map { $_->name } @{$_[0]->type_constraints} }
 128
 129 # NOTE:
 130 # this should probably never be used
 131 # but we include it here for completeness
 132 sub constraint    {
 133     my $self = shift;
 134     sub { $self->check($_[0]) };
 135 }
 136
 137 # conform to the TypeConstraint API
 138 sub parent        { undef  }
 139 sub coercion      { undef  }
 140 sub has_coercion  { 0      }
 141 sub message       { undef  }
 142 sub has_message   { 0      }
 143
 144 sub check {
 145     my $self  = shift;
 146     my $value = shift;
 147     foreach my $type (@{$self->type_constraints}) {
 148         return 1 if $type->check($value);
 149     }
 150     return undef;
 151 }
 152
 153 sub validate {
 154     my $self  = shift;
 155     my $value = shift;
 156     my $message;
 157     foreach my $type (@{$self->type_constraints}) {
 158         my $err = $type->validate($value);
 159         return unless defined $err;
 160         $message .= ($message ? ' and ' : '') . $err
 161             if defined $err;
 162     }
 163     return ($message . ' in (' . $self->name . ')') ;
 164 }
 165
 166 sub is_a_type_of {
 167     my ($self, $type_name) = @_;
 168     foreach my $type (@{$self->type_constraints}) {
 169         return 1 if $type->is_a_type_of($type_name);
 170     }
 171     return 0;
 172 }
 173
 174 sub is_subtype_of {
 175     my ($self, $type_name) = @_;
 176     foreach my $type (@{$self->type_constraints}) {
 177         return 1 if $type->is_subtype_of($type_name);
 178     }
 179     return 0;
 180 }
 181
 182 1;
 183
 184 __END__
 185
 186 =pod
 187
 188 =head1 NAME
 189
 190 Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
 191
 192 =head1 DESCRIPTION
 193
 194 For the most part, the only time you will ever encounter an
 195 instance of this class is if you are doing some serious deep
 196 introspection. This API should not be considered final, but
 197 it is B<highly unlikely> that this will matter to a regular
 198 Moose user.
 199
 200 If you wish to use features at this depth, please come to the
 201 #moose IRC channel on irc.perl.org and we can talk :)
 202
 203 =head1 METHODS
 204
 205 =over 4
 206
 207 =item B<meta>
 208
 209 =item B<new>
 210
 211 =item B<is_a_type_of ($type_name)>
 212
 213 This checks the current type name, and if it does not match,
 214 checks if it is a subtype of it.
 215
 216 =item B<is_subtype_of ($type_name)>
 217
 218 =item B<compile_type_constraint>
 219
 220 =item B<check ($value)>
 221
 222 This method will return a true (C<1>) if the C<$value> passes the
 223 constraint, and false (C<0>) otherwise.
 224
 225 =item B<validate ($value)>
 226
 227 This method is similar to C<check>, but it deals with the error
 228 message. If the C<$value> passes the constraint, C<undef> will be
 229 returned. If the C<$value> does B<not> pass the constraint, then
 230 the C<message> will be used to construct a custom error message.
 231
 232 =item B<name>
 233
 234 =item B<parent>
 235
 236 =item B<constraint>
 237
 238 =item B<has_message>
 239
 240 =item B<message>
 241
 242 =item B<has_coercion>
 243
 244 =item B<coercion>
 245
 246 =back
 247
 248 =over 4
 249
 250 =item B<union (@type_constraints)>
 251
 252 =back
 253
 254 =head1 BUGS
 255
 256 All complex software has bugs lurking in it, and this module is no
 257 exception. If you find a bug please either email me, or add the bug
 258 to cpan-RT.
 259
 260 =head1 AUTHOR
 261
 262 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 263
 264 =head1 COPYRIGHT AND LICENSE
 265
 266 Copyright 2006 by Infinity Interactive, Inc.
 267
 268 L<http://www.iinteractive.com>
 269
 270 This library is free software; you can redistribute it and/or modify
 271 it under the same terms as Perl itself.
 272
 273 =cut