summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2019-12-05 18:52:35 +0100
committerYorhel <git@yorhel.nl>2019-12-05 18:52:35 +0100
commit96cfe6180a33c90d22b15c2ae95a1938ad3a75b7 (patch)
treeae27f737f5e02ac50ac5d6a487a4d5eaeeee0127
parent5c64a47ee000cff7777f8b6ee777dc38bdbec163 (diff)
TUWF::Validate: Add "onerror" built-in validation
-rw-r--r--lib/TUWF/Validate.pm13
-rw-r--r--lib/TUWF/Validate.pod14
-rw-r--r--t/validate.t4
3 files changed, 25 insertions, 6 deletions
diff --git a/lib/TUWF/Validate.pm b/lib/TUWF/Validate.pm
index 2d46330..fbdfd5c 100644
--- a/lib/TUWF/Validate.pm
+++ b/lib/TUWF/Validate.pm
@@ -14,6 +14,7 @@ our $VERSION = '1.4';
my %builtin = map +($_,1), qw/
type
required default
+ onerror
rmwhitespace
values scalar sort unique
keys unknown
@@ -141,7 +142,8 @@ sub _compile {
croak "Incompatible types, the schema specifies '$top{type}' but validation '$t->{name}' requires '$t->{schema}{type}'" if $schema->{type};
croak "Incompatible types, '$t->[0]' requires '$t->{schema}{type}', but another validation requires '$top{type}'";
}
- exists $t->{schema}{$_} and $top{$_} //= delete $t->{schema}{$_} for qw/required default rmwhitespace type scalar unknown sort unique/;
+ exists $t->{schema}{$_} and !exists $top{$_} and $top{$_} = delete $t->{schema}{$_}
+ for qw/required default onerror rmwhitespace type scalar unknown sort unique/;
push @keys, keys %{ delete $t->{known_keys} };
push @keys, keys %{ $t->{schema}{keys} } if $t->{schema}{keys};
@@ -284,7 +286,7 @@ sub _validate_array {
}
-sub _validate {
+sub _validate_input {
my($c, $input) = @_;
# rmwhitespace (needs to be done before the 'required' test)
@@ -340,6 +342,13 @@ sub _validate {
}
+sub _validate {
+ my($c, $input) = @_;
+ my $r = _validate_input($c, $input);
+ $r->[1] && exists $c->{schema}{onerror} ? [$c->{schema}{onerror}] : $r
+}
+
+
sub validate {
my($c, $input) = ref $_[0] eq __PACKAGE__ ? @_ : (compile($_[0], $_[1]), $_[2]);
bless _validate($c, $input), 'TUWF::Validate::Result';
diff --git a/lib/TUWF/Validate.pod b/lib/TUWF/Validate.pod
index 86c789a..234c60f 100644
--- a/lib/TUWF/Validate.pod
+++ b/lib/TUWF/Validate.pod
@@ -174,6 +174,12 @@ Default: true.
The value to return if I<required> is false and the input is empty or undef.
+=item onerror => $val
+
+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.
+
=item rmwhitespace => 0/1
By default, any whitespace around scalar-type input is removed before testing
@@ -349,10 +355,10 @@ On success, the subroutine should return a true value. On failure, it should
return either a false value or a hashref. The hashref will have the
I<validation> key set to I<func>, and this will be returned as error object.
-(Note that, when I<func> is used inside a custom validation, the returned error
-object will have its I<validation> field set to the name of the custom
-validation. This makes custom validations to behave as first-class validations
-in terms of error reporting).
+When I<func> is used inside a custom validation, the returned error object will
+have its I<validation> field set to the name of the custom validation. This
+makes custom validations to behave as first-class validations in terms of error
+reporting.
=back
diff --git a/t/validate.t b/t/validate.t
index dbb1582..f3315cc 100644
--- a/t/validate.t
+++ b/t/validate.t
@@ -16,6 +16,7 @@ my %validations = (
prefix => sub { my $p = shift; { func => sub { $_[0] =~ /^$p/ } } },
bool => { required => 0, default => 0, func => sub { $_[0] = $_[0]?1:0; 1 } },
collapsews => { rmwhitespace => 0, func => sub { $_[0] =~ s/\s+/ /g; 1 } },
+ neverfails => { onerror => 'err' },
revnum => { type => 'array', sort => sub { $_[1] <=> $_[0] } },
uniquelength => { type => 'array', values => { type => 'array' }, unique => sub { scalar @{$_[0]} } },
person => {
@@ -159,6 +160,9 @@ t { person => 1, keys => {extra => {}} }, {name => 'x', extra => 1}, { name => '
t { person => 1, keys => {extra => {}} }, {name => 'x', extra => ''}, { name => 'x', extra => '' }, { validation => 'keys', errors => [{ key => 'extra', validation => 'required' }] };
t { person => 1 }, {name => 'x', extra => 1}, {name => 'x', extra => 1}, undef;
t { person => 1, unknown => 'remove' }, {name => 'x', extra => 1}, {name => 'x'}, undef;
+t { neverfails => 1, int => 1 }, undef, 'err', undef;
+t { neverfails => 1, int => 1 }, 'x', 'err', undef;
+t { neverfails => 1, int => 1, onerror => undef }, 'x', undef, undef; # XXX: no way to 'unset' an inherited onerror clause, hmm.
# numbers
sub nerr { +{ validation => 'num', got => $_[0] } }