lib/DBIx/Class/CDBICompat/Constraints.pm

   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_exception("constraint_column needs a valid column");
  10   my $how = shift
  11     or return $class->throw_exception("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_exception("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_exception("Constraint needs a name");
  32   my $column = $class->find_column(+shift)
  33     or return $class->throw_exception("Constraint $name needs a valid column");
  34   my $code = shift
  35     or return $class->throw_exception("Constraint $name needs a code reference");
  36   return $class->throw_exception("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_exception(
  45         "$class $column fails '$name' constraint with '$value'");
  46     }
  47   );
  48 }
  49
  50 1;