1package # hide from PAUSE
2    DBIx::Class::CDBICompat::Constraints;
3
4use strict;
5use warnings;
6
7sub 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
29sub 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
511;
52