Constraint support added to compat layer (no is_constrained though)

diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm
index aa88e4b..a054a47 100644 (file)
--- a/lib/DBIx/Class/CDBICompat.pm
+++ b/lib/DBIx/Class/CDBICompat.pm
@@ -3,7 +3,8 @@ package DBIx::Class::CDBICompat;
 use strict;
 use warnings;
 
-use base qw/DBIx::Class::CDBICompat::Triggers
+use base qw/DBIx::Class::CDBICompat::Constraints
+            DBIx::Class::CDBICompat::Triggers
             DBIx::Class::CDBICompat::GetSet
             DBIx::Class::CDBICompat::LiveObjectIndex
             DBIx::Class::CDBICompat::AttributeAPI

diff --git a/lib/DBIx/Class/CDBICompat/Constraints.pm b/lib/DBIx/Class/CDBICompat/Constraints.pm
new file mode 100644 (file)
index 0000000..f712627
--- /dev/null
+++ b/lib/DBIx/Class/CDBICompat/Constraints.pm
@@ -0,0 +1,50 @@
+package DBIx::Class::CDBICompat::Constraints;
+
+use strict;
+use warnings;
+
+sub constrain_column {
+  my $class = shift;
+  my $col   = $class->find_column(+shift)
+    or return $class->throw("constraint_column needs a valid column");
+  my $how = shift
+    or return $class->throw("constrain_column needs a constraint");
+  if (ref $how eq "ARRAY") {
+    my %hash = map { $_ => 1 } @$how;
+    $class->add_constraint(list => $col => sub { exists $hash{ +shift } });
+  } elsif (ref $how eq "Regexp") {
+    $class->add_constraint(regexp => $col => sub { shift =~ $how });
+  } else {
+    $how =~ m/([^:]+)$/;
+    my $try_method = sprintf '_constrain_by_%s', lc $1; # $how->moniker;
+    if (my $dispatch = $class->can($try_method)) {
+      $class->$dispatch($col => ($how, @_));
+    } else {
+      $class->throw("Don't know how to constrain $col with $how");
+    }
+  }
+}
+
+sub add_constraint {
+  my $class = shift;
+  $class->_invalid_object_method('add_constraint()') if ref $class;
+  my $name = shift or return $class->throw("Constraint needs a name");
+  my $column = $class->find_column(+shift)
+    or return $class->throw("Constraint $name needs a valid column");
+  my $code = shift
+    or return $class->throw("Constraint $name needs a code reference");
+  return $class->throw("Constraint $name '$code' is not a code reference")
+    unless ref($code) eq "CODE";
+
+  #$column->is_constrained(1);
+  $class->add_trigger(
+    "before_set_$column" => sub {
+      my ($self, $value, $column_values) = @_;
+      $code->($value, $self, $column, $column_values)
+        or return $self->throw(
+        "$class $column fails '$name' constraint with '$value'");
+    }
+  );
+}
+
+1;

diff --git a/lib/DBIx/Class/CDBICompat/Triggers.pm b/lib/DBIx/Class/CDBICompat/Triggers.pm
index 46a0d49..3bf8070 100644 (file)
--- a/lib/DBIx/Class/CDBICompat/Triggers.pm
+++ b/lib/DBIx/Class/CDBICompat/Triggers.pm
@@ -1,5 +1,7 @@
 package DBIx::Class::CDBICompat::Triggers;
 
+use strict;
+use warnings;
 use Class::Trigger;
 
 sub insert {
@@ -28,4 +30,11 @@ sub delete {
   return $self;
 }
 
+sub store_column {
+  my ($self, $column, $value, @rest) = @_;
+  my $vals = { $column => $value };
+  $self->call_trigger("before_set_${column}", $value, $vals);
+  return $self->NEXT::ACTUAL::store_column($column, $vals->{$column});
+}
+
 1;