use
vars
qw/$AUTOLOAD $VERSION/
;
$VERSION
= 3.13;
sub
new {
my
$proto
=
shift
;
my
$class
=
ref
$proto
||
$proto
;
my
(
$profile
,
$data
) =
@_
;
my
$self
=
bless
{},
$class
;
$self
->_process(
$profile
,
$data
);
$self
;
}
sub
_process {
my
(
$self
,
$profile
,
$data
) =
@_
;
my
%data
=
$self
->_get_data(
$data
);
my
%valid
=
%data
;
my
@missings
= ();
my
@invalid
= ();
my
@unknown
= ();
$self
->{profile} =
$profile
;
my
%imported_validators
;
foreach
my
$package
(_arrayify(
$profile
->{validator_packages})) {
if
( !
exists
$imported_validators
{
$package
} ) {
eval
"require $package"
;
if
($@) {
die
"Couldn't load validator package '$package': $@"
;
}
my
$package_ref
= qualify_to_ref(
"${package}::"
);
my
@subs
=
grep
(/^(valid_|match_)/,
keys
(%{*{
$package_ref
}}));
foreach
my
$sub
(
@subs
) {
my
$subref
= *{qualify_to_ref(
"${package}::$sub"
)}{CODE};
if
(
defined
$subref
) {
*{qualify_to_ref(
$sub
)} =
$subref
;
}
}
$imported_validators
{
$package
} = 1;
}
}
foreach
my
$filter
(_arrayify(
$profile
->{filters})) {
if
(
defined
$filter
) {
$filter
= (
ref
$filter
?
$filter
: *{qualify_to_ref(
"filter_$filter"
)}{CODE}) ||
die
"No filter found named: '$filter'"
;
foreach
my
$field
(
keys
%valid
) {
_filter_apply(\
%valid
,
$field
,
$filter
);
}
}
}
while
(
my
(
$field
,
$filters
) =
each
%{
$profile
->{field_filters} }) {
foreach
my
$filter
( _arrayify(
$filters
)) {
if
(
defined
$filter
) {
$filter
= (
ref
$filter
?
$filter
: *{qualify_to_ref(
"filter_$filter"
)}{CODE}) ||
die
"No filter found named '$filter'"
;
_filter_apply(\
%valid
,
$field
,
$filter
);
}
}
}
while
(
my
(
$re
,
$filters
) =
each
%{
$profile
->{field_filter_regexp_map} }) {
my
$sub
= _create_sub_from_RE(
$re
);
foreach
my
$filter
( _arrayify(
$filters
)) {
if
(
defined
$filter
) {
$filter
= (
ref
$filter
?
$filter
: *{qualify_to_ref(
"filter_$filter"
)}{CODE}) ||
die
"No filter found named '$filter'"
;
no
strict
'refs'
;
for
my
$field
(
grep
{
$sub
->(
$_
) } (
keys
%valid
)) {
_filter_apply(\
%valid
,
$field
,
$filter
);
}
}
}
}
my
%required
=
map
{
$_
=> 1 } _arrayify(
$profile
->{required});
my
%optional
=
map
{
$_
=> 1 } _arrayify(
$profile
->{optional});
my
$required_re
= _create_sub_from_RE(
$profile
->{required_regexp});
my
$optional_re
= _create_sub_from_RE(
$profile
->{optional_regexp});
foreach
my
$k
(
keys
%valid
) {
if
(
$required_re
&&
$required_re
->(
$k
)) {
$required
{
$k
} = 1;
}
if
(
$optional_re
&&
$optional_re
->(
$k
)) {
$optional
{
$k
} = 1;
}
}
my
%require_some
;
while
(
my
(
$field
,
$deps
) =
each
%{
$profile
->{require_some}} ) {
foreach
my
$dep
(_arrayify(
$deps
)){
$require_some
{
$dep
} = 1;
}
}
foreach
my
$field
(
keys
%valid
) {
if
(
ref
$valid
{
$field
}) {
if
(
ref
$valid
{
$field
} eq
'ARRAY'
) {
for
(
my
$i
= 0;
$i
<
scalar
@{
$valid
{
$field
} };
$i
++) {
$valid
{
$field
}->[
$i
] =
undef
unless
(
defined
$valid
{
$field
}->[
$i
] and
length
$valid
{
$field
}->[
$i
]);
}
}
}
else
{
delete
$valid
{
$field
}
unless
(
defined
$valid
{
$field
} and
length
$valid
{
$field
});
}
}
while
(
my
(
$field
,
$deps
) =
each
%{
$profile
->{dependencies}} ) {
if
(
$valid
{
$field
}) {
if
(
ref
(
$deps
) eq
'HASH'
) {
foreach
my
$key
(
keys
%$deps
) {
if
(
$valid
{
$field
} eq
$key
){
foreach
my
$dep
(_arrayify(
$deps
->{
$key
})){
$required
{
$dep
} = 1;
}
}
}
}
else
{
foreach
my
$dep
(_arrayify(
$deps
)){
$required
{
$dep
} = 1;
}
}
}
}
foreach
my
$group
(
values
%{
$profile
->{dependency_groups} }) {
my
$require_all
= 0;
foreach
my
$field
(_arrayify(
$group
)) {
$require_all
= 1
if
$valid
{
$field
};
}
if
(
$require_all
) {
map
{
$required
{
$_
} = 1 } _arrayify(
$group
);
}
}
@unknown
=
grep
{ not (
exists
$optional
{
$_
} or
exists
$required
{
$_
} or
exists
$require_some
{
$_
} ) }
keys
%valid
;
foreach
my
$field
(
@unknown
) {
delete
$valid
{
$field
};
}
while
(
my
(
$field
,
$value
) =
each
%{
$profile
->{defaults}} ) {
$valid
{
$field
} =
$value
unless
exists
$valid
{
$field
};
}
foreach
my
$field
(
keys
%required
) {
push
@missings
,
$field
unless
exists
$valid
{
$field
};
}
while
(
my
(
$field
,
$deps
) =
each
%{
$profile
->{require_some}} ) {
my
$enough_required_fields
= 0;
my
@deps
= _arrayify(
$deps
);
my
$num_fields_to_require
= (
$deps
[0] =~ m/^\d+$/) ?
$deps
[0] : 1;
foreach
my
$dep
(
@deps
){
$enough_required_fields
++
if
exists
$valid
{
$dep
};
}
push
@missings
,
$field
unless
(
$enough_required_fields
>=
$num_fields_to_require
);
}
foreach
my
$re
(
keys
%{
$profile
->{constraint_regexp_map} }) {
my
$sub
= _create_sub_from_RE(
$re
);
for
my
$key
(
keys
%valid
) {
if
(
$sub
->(
$key
)) {
my
$cur
=
$profile
->{constraints}{
$key
};
my
$new
=
$profile
->{constraint_regexp_map}{
$re
};
if
(
ref
$cur
eq
'ARRAY'
) {
push
@{
$profile
->{constraints}{
$key
} },
$new
;
}
elsif
(
$cur
) {
$profile
->{constraints}{
$key
} = [
$cur
,
$new
];
}
else
{
$profile
->{constraints}{
$key
} =
$new
;
}
warn
"constraint_regexp_map: $key matches\n"
if
$profile
->{debug};
}
}
}
my
(
$untaint_all
,
%untaint_hash
);
if
(
defined
(
$profile
->{untaint_constraint_fields})) {
if
(
ref
$profile
->{untaint_constraint_fields} eq
"ARRAY"
) {
foreach
my
$field
(@{
$profile
->{untaint_constraint_fields}}) {
$untaint_hash
{
$field
} = 1;
}
}
elsif
(
$valid
{
$profile
->{untaint_constraint_fields}}) {
$untaint_hash
{
$profile
->{untaint_constraint_fields}} = 1;
}
}
elsif
((
defined
(
$profile
->{untaint_all_constraints}))
&& (
$profile
->{untaint_all_constraints} == 1)) {
$untaint_all
= 1;
}
while
(
my
(
$field
,
$constraint_list
) =
each
%{
$profile
->{constraints}} ) {
next
unless
exists
$valid
{
$field
};
my
$is_constraint_list
= 1
if
(
ref
$constraint_list
eq
'ARRAY'
);
my
$untaint_this
= (
$untaint_all
||
$untaint_hash
{
$field
} || 0);
my
@invalid_list
;
foreach
my
$constraint_spec
(_arrayify(
$constraint_list
)) {
$self
->{__CURRENT_CONSTRAINT_FIELD} =
$field
;
my
$c
=
$self
->_constraint_hash_build(
$field
,
$constraint_spec
,
$untaint_this
);
my
$is_value_list
= 1
if
(
ref
$valid
{
$field
} eq
'ARRAY'
);
if
(
$is_value_list
) {
foreach
(
my
$i
= 0;
$i
<
scalar
@{
$valid
{
$field
}} ;
$i
++) {
my
@params
=
$self
->_constraint_input_build(
$c
,
$valid
{
$field
}->[
$i
],\
%valid
);
$self
->{__CURRENT_CONSTRAINT_VALUE} =
$valid
{
$field
}->[
$i
];
my
(
$match
,
$failed
) = _constraint_check_match(
$c
,\
@params
);
if
(
$failed
) {
push
@invalid_list
,
$failed
;
}
else
{
$valid
{
$field
}->[
$i
] =
$match
if
$untaint_this
;
}
}
}
else
{
my
@params
=
$self
->_constraint_input_build(
$c
,
$valid
{
$field
},\
%valid
);
$self
->{__CURRENT_CONSTRAINT_VALUE} =
$valid
{
$field
};
my
(
$match
,
$failed
) = _constraint_check_match(
$c
,\
@params
);
if
(
$failed
) {
push
@invalid_list
,
$failed
}
else
{
$valid
{
$field
} =
$match
if
$untaint_this
;
}
}
}
if
(
@invalid_list
) {
if
(
$is_constraint_list
) {
my
@failed
=
map
{
$_
->{name} }
@invalid_list
;
push
@invalid
, [
$field
,
@failed
];
push
@{
$self
->{invalid}->{
$field
} },
@failed
;
}
else
{
push
@invalid
,
$field
;
push
@{
$self
->{invalid}->{
$field
} },
$invalid_list
[0]->{name} ;
}
delete
$valid
{
$field
};
}
}
foreach
my
$field
(
keys
%data
) {
if
(
$profile
->{missing_optional_valid} and
$optional
{
$field
} and (not
exists
$valid
{
$field
})) {
$valid
{
$field
} =
undef
;
}
}
my
(
$missing
,
$invalid
);
$self
->{valid} ||= {};
$self
->{valid} = {
%valid
, %{
$self
->{valid}} };
$self
->{validate_invalid} = \
@invalid
|| [];
$self
->{missing} = {
map
{
$_
=> 1 }
@missings
};
$self
->{unknown} = {
map
{
$_
=> 1 }
@unknown
};
}
sub
valid {
my
$self
=
shift
;
my
$key
=
shift
;
my
$val
=
shift
;
$self
->{valid}{
$key
} =
$val
if
defined
$val
;
return
$self
->{valid}{
$key
}
if
defined
$key
;
wantarray
?
keys
%{
$self
->{valid} } :
$self
->{valid};
}
sub
has_missing {
return
scalar
keys
%{
$_
[0]{missing}};
}
sub
missing {
return
$_
[0]{missing}{
$_
[1]}
if
(
defined
$_
[1]);
wantarray
?
keys
%{
$_
[0]{missing}} : [
keys
%{
$_
[0]{missing}} ];
}
sub
has_invalid {
return
scalar
keys
%{
$_
[0]{invalid}};
}
sub
invalid {
my
$self
=
shift
;
my
$field
=
shift
;
return
$self
->{invalid}{
$field
}
if
defined
$field
;
wantarray
?
keys
%{
$self
->{invalid}} :
$self
->{invalid};
}
sub
has_unknown {
return
scalar
keys
%{
$_
[0]{unknown}};
}
sub
unknown {
return
$_
[0]{unknown}{
$_
[1]}
if
(
defined
$_
[1]);
wantarray
?
keys
%{
$_
[0]{unknown}} :
$_
[0]{unknown};
}
sub
msgs {
my
$self
=
shift
;
my
$controls
=
shift
|| {};
if
(
defined
$controls
and
ref
$controls
ne
'HASH'
) {
die
"$0: parameter passed to msgs must be a hash ref"
;
}
$self
->{msgs} ||= {};
$self
->{profile}->{msgs} ||= {};
$self
->{msgs} = { %{
$self
->{msgs} },
%$controls
};
my
%profile
= (
prefix
=>
''
,
missing
=>
'Missing'
,
invalid
=>
'Invalid'
,
invalid_seperator
=>
' '
,
format
=>
'<span style="color:red;font-weight:bold"><span id="dfv_errors">* %s</span></span>'
,
%{
$self
->{msgs} },
%{
$self
->{profile}->{msgs} },
);
my
%msgs
= ();
if
(
$self
->has_invalid) {
my
$invalid
=
$self
->invalid;
for
my
$i
(
keys
%$invalid
) {
$msgs
{
$i
} =
join
$profile
{invalid_seperator},
map
{
_error_msg_fmt(
$profile
{
format
},(
$profile
{constraints}{
$_
} ||
$profile
{invalid}))
} @{
$invalid
->{
$i
} };
}
}
if
(
$self
->has_missing) {
my
$missing
=
$self
->missing;
for
my
$m
(
@$missing
) {
$msgs
{
$m
} = _error_msg_fmt(
$profile
{
format
},
$profile
{missing});
}
}
my
$msgs_ref
= prefix_hash(
$profile
{prefix},\
%msgs
);
$msgs_ref
->{
$profile
{any_errors} } = 1
if
defined
$profile
{any_errors};
return
$msgs_ref
;
}
sub
get_input_data {
my
$self
=
shift
;
return
$self
->{__INPUT_DATA};
}
sub
get_current_constraint_field {
my
$self
=
shift
;
return
$self
->{__CURRENT_CONSTRAINT_FIELD};
}
sub
get_current_constraint_value {
my
$self
=
shift
;
return
$self
->{__CURRENT_CONSTRAINT_VALUE};
}
sub
get_current_constraint_name {
my
$self
=
shift
;
return
$self
->{__CURRENT_CONSTRAINT_NAME};
}
sub
prefix_hash {
my
(
$pre
,
$href
) =
@_
;
die
"prefix_hash: need two arguments"
unless
(
scalar
@_
== 2);
die
"prefix_hash: second argument must be a hash ref"
unless
(
ref
$href
eq
'HASH'
);
my
%out
;
for
(
keys
%$href
) {
$out
{
$pre
.
$_
} =
$href
->{
$_
};
}
return
\
%out
;
}
sub
_create_sub_from_RE {
my
$re
=
shift
||
return
undef
;
my
$untaint_this
=
shift
;
my
$return_code
= (
$untaint_this
) ?
'; return ($& =~ m/(.*)/s)[0] if defined($`);'
:
''
;
my
$sub
;
if
(
substr
(
$re
,0,1) eq
'('
) {
$sub
=
sub
{
my
$match
=
$_
[0] =~
$re
;
if
(
$untaint_this
&&
defined
$-[0]) {
return
(
substr
(
$_
[0], $-[0], $+[0] - $-[0]) =~ m/(.*)/s)[0];
}
else
{
return
$match
;
}
};
}
else
{
$sub
=
eval
'sub { $_[0] =~ '
.
$re
.
$return_code
.
'}'
;
}
die
"Error compiling regular expression $re: $@"
if
$@;
return
$sub
;
}
sub
_error_msg_fmt ($$) {
my
(
$fmt
,
$msg
) =
@_
;
$fmt
||=
'<span style="color:red;font-weight:bold"><span id="vrm_errors">* %s</span></span>'
;
(
$fmt
=~ m/
%s
/) ||
die
'format must contain %s'
;
return
sprintf
$fmt
,
$msg
;
}
sub
_arrayify {
my
$val
=
shift
;
defined
$val
or
return
();
if
(
ref
$val
eq
'ARRAY'
) {
return
(
length
$val
->[0]) ?
@$val
: ();
}
else
{
return
(
length
$val
) ? (
$val
) : ();
}
}
sub
_filter_apply {
my
(
$valid
,
$field
,
$filter
) =
@_
;
die
'wrong number of arguments passed to _filter_apply'
unless
(
scalar
@_
== 3);
if
(
ref
$valid
->{
$field
} eq
'ARRAY'
) {
for
(
my
$i
= 0;
$i
< @{
$valid
->{
$field
} };
$i
++) {
$valid
->{
$field
}->[
$i
] =
$filter
->(
$valid
->{
$field
}->[
$i
] )
if
defined
$valid
->{
$field
}->[
$i
];
}
}
else
{
$valid
->{
$field
} =
$filter
->(
$valid
->{
$field
} )
if
defined
$valid
->{
$field
};
}
}
sub
_constraint_hash_build {
my
(
$self
,
$field
,
$constraint_spec
,
$untaint_this
) =
@_
;
die
"_constraint_apply received wrong number of arguments"
unless
(
scalar
@_
== 4);
my
$c
= {
name
=>
$constraint_spec
,
constraint
=>
$constraint_spec
,
};
if
(
ref
$c
->{constraint} eq
'HASH'
) {
$c
->{constraint} = (
$constraint_spec
->{constraint_method} ||
$constraint_spec
->{constraint});
$c
->{name} =
$constraint_spec
->{name};
$c
->{params} =
$constraint_spec
->{params};
$c
->{is_method} = 1
if
$constraint_spec
->{constraint_method};
}
if
((
ref
$c
->{constraint} eq
'Regexp'
)
or (
$c
->{constraint} =~ m@^\s*(/.+/|m(.).+\2)[cgimosx]*\s*$@ )) {
$c
->{constraint} = _create_sub_from_RE(
$c
->{constraint},
$untaint_this
);
}
elsif
(
ref
$c
->{constraint} eq
'CODE'
) {
}
else
{
$c
->{name} ||=
$c
->{constraint};
$self
->{__CURRENT_CONSTRAINT_NAME} =
$c
->{name};
if
(
$untaint_this
) {
my
$routine
=
'match_'
.
$c
->{constraint};
my
$match_sub
= *{qualify_to_ref(
$routine
)}{CODE};
if
(
$match_sub
) {
$c
->{constraint} =
$match_sub
;
}
elsif
(
$c
->{constraint} =~ m/^RE_/) {
$c
->{is_method} = 1;
$c
->{constraint} =
eval
'sub { &_create_regexp_common_constraint(@_)}'
||
die
"could not create Regexp::Common constraint: $@"
;
}
else
{
die
"No untainting constraint found named $c->{constraint}"
;
}
}
else
{
my
$routine
=
'match_'
.
$c
->{constraint};
if
(
defined
*{qualify_to_ref(
$routine
)}{CODE}) {
$c
->{constraint} =
eval
'sub { no strict qw/refs/; return defined &{"match_'
.
$c
->{constraint}.
'"}(@_)}'
;
}
elsif
(
my
$valid_sub
= *{qualify_to_ref(
'valid_'
.
$c
->{constraint})}{CODE}) {
$c
->{constraint} =
$valid_sub
;
}
elsif
(
$c
->{constraint} =~ m/^RE_/) {
$c
->{is_method} = 1;
$c
->{constraint} =
eval
'sub { return defined &_create_regexp_common_constraint(@_)}'
||
die
"could not create Regexp::Common constraint: $@"
;
}
else
{
die
"No constraint found named '$c->{name}'"
;
}
}
}
return
$c
;
}
sub
_constraint_input_build {
my
(
$self
,
$c
,
$value
,
$valid
) =
@_
;
die
"_constraint_input_build received wrong number of arguments"
unless
(
scalar
@_
== 4);
my
@params
;
if
(
defined
$c
->{params}) {
foreach
my
$fname
(_arrayify(
$c
->{params})) {
push
@params
, (
ref
$fname
) ?
$fname
:
$valid
->{
$fname
}
}
}
else
{
push
@params
,
$value
;
}
unshift
@params
,
$self
if
$c
->{is_method};
return
@params
;
}
sub
_constraint_check_match {
my
(
$c
,
$params
) =
@_
;
die
"_constraint_check_match received wrong number of arguments"
unless
(
scalar
@_
== 2);
if
(
my
$match
=
$c
->{constraint}->(
@$params
)) {
return
$match
;
}
else
{
return
undef
,
{
failed
=> 1,
name
=>
$c
->{name},
};
}
}
sub
_get_data {
my
(
$self
,
$data
) =
@_
;
$self
->{__INPUT_DATA} =
$data
;
if
(UNIVERSAL::isa(
$data
,
'CGI'
) || UNIVERSAL::isa(
$data
,
'Apache::Request'
) ) {
my
%return
;
defined
(
$data
->UNIVERSAL::can(
'param'
)) or
croak(
"Data::FormValidator->validate called with CGI or Apache::Request object which lacks a param() method!"
);
foreach
my
$k
(
$data
->param()){
my
@v
=
$data
->param(
$k
);
$return
{
$k
} =
scalar
(
@v
)>1 ? \
@v
:
$v
[0];
}
return
%return
;
}
else
{
return
%$data
;
}
}
sub
_create_regexp_common_constraint {
import
Regexp::Common
'RE_ALL'
;
my
$self
=
shift
;
my
$re_name
=
$self
->get_current_constraint_name;
my
@params
=
map
{
$_
=
$$_
if
ref
$_
}
@_
;
no
strict
"refs"
;
my
$re
=
&$re_name
(
-keep
=>1,
@params
) ||
die
'no matching Regexp::Common routine found'
;
return
(
$self
->get_current_constraint_value =~
qr/^$re$/
) ? $1 :
undef
;
}
1;