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