TUWF::Validation: Allow CODE references for default and onerror options

3 files changed, 15 insertions, 2 deletions

diff --git a/lib/TUWF/Validate.pm b/lib/TUWF/Validate.pm
index fbdfd5c..5451c92 100644
--- a/lib/TUWF/Validate.pm
+++ b/lib/TUWF/Validate.pm
@@ -299,7 +299,7 @@ sub _validate_input {
   # required & default
   if(!defined $input || (!ref $input && $input eq '')) {
     # XXX: This will return undef if !required and no default is set, even for hash and array types. Should those get an empty hash or array?
-    return [exists $c->{schema}{default} ? $c->{schema}{default} : $input] if !$c->{schema}{required};
+    return [ref $c->{schema}{default} eq 'CODE' ? $c->{schema}{default}->($input) : exists $c->{schema}{default} ? $c->{schema}{default} : $input] if !$c->{schema}{required};
     return [$input, { validation => 'required' }];
   }
 
@@ -345,7 +345,7 @@ sub _validate_input {
 sub _validate {
   my($c, $input) = @_;
   my $r = _validate_input($c, $input);
-  $r->[1] && exists $c->{schema}{onerror} ? [$c->{schema}{onerror}] : $r
+  $r->[1] && exists $c->{schema}{onerror} ? [ref $c->{schema}{onerror} eq 'CODE' ? $c->{schema}{onerror}->(bless $r, 'TUWF::Validate::Result') : $c->{schema}{onerror}] : $r
 }
 
 
diff --git a/lib/TUWF/Validate.pod b/lib/TUWF/Validate.pod
index 234c60f..43155b3 100644
--- a/lib/TUWF/Validate.pod
+++ b/lib/TUWF/Validate.pod
@@ -173,6 +173,8 @@ Default: true.
 =item default => $val
 
 The value to return if I<required> is false and the input is empty or undef.
+If C<$val> is a CODE reference, the subroutine will be called with the original
+input as first argument and its return value will be used for this validation.
 
 =item onerror => $val
 
@@ -180,6 +182,10 @@ Instead of reporting an error, return C<$val> if this input fails validation
 for whatever reason. Setting this option in the top-level schema ensures that
 the validation will always succeed regardless of the input.
 
+If C<$val> is a CODE reference, the subroutine will be called with the result
+object for this validation as its first argument. The return value of the
+subroutine will be returned for this validation.
+
 =item rmwhitespace => 0/1
 
 By default, any whitespace around scalar-type input is removed before testing
diff --git a/t/validate.t b/t/validate.t
index f3315cc..0c56d3b 100644
--- a/t/validate.t
+++ b/t/validate.t
@@ -15,6 +15,9 @@ my %validations = (
   hex => { regex => qr/^[0-9a-f]*$/i },
   prefix => sub { my $p = shift; { func => sub { $_[0] =~ /^$p/ } } },
   bool => { required => 0, default => 0, func => sub { $_[0] = $_[0]?1:0; 1 } },
+  defaultsub1 => { default => sub { 2 } },
+  defaultsub2 => { default => sub { defined $_[0] } },
+  onerrorsub => { onerror => sub { ref $_[0] } },
   collapsews => { rmwhitespace => 0, func => sub { $_[0] =~ s/\s+/ /g; 1 } },
   neverfails => { onerror => 'err' },
   revnum => { type => 'array', sort => sub { $_[1] <=> $_[0] } },
@@ -62,6 +65,10 @@ t {}, undef, undef, { validation => 'required' };
 t { required => 0 }, undef, undef, undef;
 t { required => 0 }, '', '', undef;
 t { required => 0, default => '' }, undef, '', undef;
+t { required => 0, defaultsub1 => 1 }, undef, 2, undef;
+t { required => 0, defaultsub2 => 1 }, undef, '', undef;
+t { required => 0, defaultsub2 => 1 }, '', 1, undef;
+t { onerrorsub => 1 }, undef, 'TUWF::Validate::Result', undef;
 
 # rmwhitespace
 t {}, " Va\rl id \n ", 'Val id', undef;