lib/DBIx/Class/CDBICompat/Constraints.pm

   1 package # hide from PAUSE
   2     DBIx::Class::CDBICompat::Constraints;
   3
   4 use base 'DBIx::Class';
   5
   6 use strict;
   7 use warnings;
   8
   9 sub constrain_column {
  10   my $class = shift;
  11   my $col   = $class->find_column(+shift)
  12     or return $class->throw_exception("constraint_column needs a valid column");
  13   my $how = shift
  14     or return $class->throw_exception("constrain_column needs a constraint");
  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 {
  21     $how =~ m/([^:]+)$/; # match is safe - we throw above on empty $how
  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 {
  26       $class->throw_exception("Don't know how to constrain $col with $how");
  27     }
  28   }
  29 }
  30
  31 sub add_constraint {
  32   my $class = shift;
  33   $class->_invalid_object_method('add_constraint()') if ref $class;
  34   my $name = shift or return $class->throw_exception("Constraint needs a name");
  35   my $column = $class->find_column(+shift)
  36     or return $class->throw_exception("Constraint $name needs a valid column");
  37   my $code = shift
  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")
  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)
  47         or return $self->throw_exception(
  48         "$class $column fails '$name' constraint with '$value'");
  49     }
  50   );
  51 }
  52
  53 1;