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