Merge branch 'master' into topic/constructor_rewrite
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / CDBICompat / Constraints.pm
1 package # hide from PAUSE
2     DBIx::Class::CDBICompat::Constraints;
3
4 use strict;
5 use warnings;
6
7 sub constrain_column {
8   my $class = shift;
9   my $col   = $class->find_column(+shift)
10     or return $class->throw_exception("constraint_column needs a valid column");
11   my $how = shift
12     or return $class->throw_exception("constrain_column needs a constraint");
13   if (ref $how eq "ARRAY") {
14     my %hash = map { $_ => 1 } @$how;
15     $class->add_constraint(list => $col => sub { exists $hash{ +shift } });
16   } elsif (ref $how eq "Regexp") {
17     $class->add_constraint(regexp => $col => sub { shift =~ $how });
18   } else {
19     $how =~ m/([^:]+)$/;
20     my $try_method = sprintf '_constrain_by_%s', lc $1; # $how->moniker;
21     if (my $dispatch = $class->can($try_method)) {
22       $class->$dispatch($col => ($how, @_));
23     } else {
24       $class->throw_exception("Don't know how to constrain $col with $how");
25     }
26   }
27 }
28
29 sub add_constraint {
30   my $class = shift;
31   $class->_invalid_object_method('add_constraint()') if ref $class;
32   my $name = shift or return $class->throw_exception("Constraint needs a name");
33   my $column = $class->find_column(+shift)
34     or return $class->throw_exception("Constraint $name needs a valid column");
35   my $code = shift
36     or return $class->throw_exception("Constraint $name needs a code reference");
37   return $class->throw_exception("Constraint $name '$code' is not a code reference")
38     unless ref($code) eq "CODE";
39
40   #$column->is_constrained(1);
41   $class->add_trigger(
42     "before_set_$column" => sub {
43       my ($self, $value, $column_values) = @_;
44       $code->($value, $self, $column, $column_values)
45         or return $self->throw_exception(
46         "$class $column fails '$name' constraint with '$value'");
47     }
48   );
49 }
50
51 1;