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