[Bast-commits] r4822 - DBIx-Class-DynamicDefault/1.000/trunk/lib/DBIx/Class

[rafl at dev.catalyst.perl.org]

Author: rafl
Date: 2008-09-18 18:13:48 +0100 (Thu, 18 Sep 2008)
New Revision: 4822

Modified:
   DBIx-Class-DynamicDefault/1.000/trunk/lib/DBIx/Class/DynamicDefault.pm
Log:
Implement defaults depending on other columns.

Modified: DBIx-Class-DynamicDefault/1.000/trunk/lib/DBIx/Class/DynamicDefault.pm
===================================================================
--- DBIx-Class-DynamicDefault/1.000/trunk/lib/DBIx/Class/DynamicDefault.pm	2008-09-18 17:13:17 UTC (rev 4821)
+++ DBIx-Class-DynamicDefault/1.000/trunk/lib/DBIx/Class/DynamicDefault.pm	2008-09-18 17:13:48 UTC (rev 4822)
@@ -3,6 +3,7 @@
 
 package DBIx::Class::DynamicDefault;
 
+use Carp qw/croak/;
 use parent 'DBIx::Class';
 
 our $VERSION = '0.03';
@@ -56,7 +57,8 @@
 
     $self->next::method(@_);
 
-    my %triggers = map { $_ => {} } qw/update create/;
+    my %triggers;
+    my %depends;
 
     for my $column ($self->columns) {
         my $info = $self->column_info($column);
@@ -65,10 +67,33 @@
 
         for my $op (qw/update create/) {
             my $meth = $info->{ "dynamic_default_on_${op}" };
-            $triggers{$op}->{$column} = [$column => sub {
+            if (ref $meth && ref $meth eq 'SCALAR') {
+                push @{ $depends{$op}->{ $$meth } }, $accessor;
+            }
+            elsif ($meth) {
+                $triggers{$op}->{$column} = [$column => sub {
+                    my $row = shift;
+                    my $default = $row->$meth;
+                    $row->$accessor($default);
+                    return $default;
+                }, $op eq 'update' ? ($info->{always_update} || 0) : ()];
+            }
+        }
+    }
+
+    for my $op (qw/update create/) {
+        while (my ($col, $deps) = each %{ $depends{$op} }) {
+            my $orig = $triggers{$op}->{$col}->[1];
+
+            unless ($orig) {
+                croak "found dynamic default depending on column ${col}, but ${col} doesn't have a dynamic default callback";
+            }
+
+            $triggers{$op}->{$col}->[1] = sub {
                 my $row = shift;
-                $row->$accessor( $row->$meth );
-            }, $op eq 'update' ? ($info->{always_update} || 0) : ()] if $meth;
+                my $default = $row->$orig;
+                $row->$_($default) for @{ $deps };
+            };
         }
     }