| 0 | 0 |
#
|
| 1 | |
# Copyright (c) 2007-2015 T. v.Dein <tlinden |AT| cpan.org>.
|
|
1 |
# Copyright (c) 2007-2016 T. v.Dein <tlinden |AT| cpan.org>.
|
| 2 | 2 |
# All Rights Reserved. Std. disclaimer applies.
|
| 3 | 3 |
# Artistic License, same as perl itself. Have fun.
|
| 4 | 4 |
#
|
|
| 20 | 20 |
use Data::Validate qw(:math is_printable);
|
| 21 | 21 |
use Data::Validate::IP qw(is_ipv4 is_ipv6);
|
| 22 | 22 |
|
| 23 | |
our $VERSION = 0.10;
|
|
23 |
our $VERSION = 0.11;
|
| 24 | 24 |
|
| 25 | 25 |
use vars qw(@ISA);
|
| 26 | 26 |
|
|
| 31 | 31 |
@EXPORT_OK = qw(add_validators);
|
| 32 | 32 |
|
| 33 | 33 |
%__ValidatorTypes = (
|
| 34 | |
# primitives
|
| 35 | |
int => sub { return defined(is_integer($_[0])); },
|
| 36 | |
hex => sub { return defined(is_hex($_[0])); },
|
| 37 | |
oct => sub { return defined(is_oct($_[0])); },
|
| 38 | |
number => sub { return defined(is_numeric($_[0])); },
|
| 39 | |
|
| 40 | |
word => qr(^[\w_\-]+$),
|
| 41 | |
line => qr/^[^\n]+$/s,
|
| 42 | |
|
| 43 | |
text => sub { return defined(is_printable($_[0])); },
|
| 44 | |
|
| 45 | |
regex => sub {
|
| 46 | |
my $r = ref $_[0];
|
| 47 | |
return 1 if $r eq 'Regexp';
|
| 48 | |
if ($r eq '') {
|
| 49 | |
# this is a bit loosy but should match most regular expressions
|
| 50 | |
# using the qr() operator, but it doesn't check if the expression
|
| 51 | |
# is valid. we could do this by compiling it, but this would lead
|
| 52 | |
# to exploitation possiblities to programs using the module.
|
| 53 | |
return $_[0] =~ qr/^qr ( (.).*\1 | \(.*\) | \{.*\} ) $/x;
|
| 54 | |
}
|
| 55 | |
return 0;
|
| 56 | |
},
|
| 57 | |
|
| 58 | |
# via imported regexes
|
| 59 | |
uri => qr(^$RE{URI}$),
|
| 60 | |
cidrv4 => sub {
|
| 61 | |
my ($p, $l) = split(/\//, $_[0]);
|
| 62 | |
return defined(is_ipv4($p)) && defined(is_between($l, 0, 32));
|
| 63 | |
},
|
| 64 | |
ipv4 => sub { defined(is_ipv4($_[0])) },
|
| 65 | |
quoted => qr/^$RE{delimited}{ -delim => qr(\') }$/,
|
| 66 | |
hostname => qr(^$host$),
|
| 67 | |
|
| 68 | |
ipv6 => sub { defined(is_ipv6($_[0])) },
|
| 69 | |
cidrv6 => sub {
|
| 70 | |
my ($p, $l) = split('/', $_[0]);
|
| 71 | |
return defined(is_ipv6($p)) && defined(is_between($l, 0, 128));
|
| 72 | |
},
|
| 73 | |
|
| 74 | |
# matches perl style scalar variables
|
| 75 | |
# possible matches: $var ${var} $(var)
|
| 76 | |
vars => qr/(?<!\\) ( \$\w+ | \$\{[^\}]+\} | \$\([^\)]+\) )/x,
|
| 77 | |
|
| 78 | |
# closures
|
| 79 | |
|
| 80 | |
# this one doesn't do a stat() syscall, so keep cool
|
| 81 | |
path => sub { return file_name_is_absolute($_[0]); },
|
| 82 | |
|
| 83 | |
# though this one does it - it stat()s if the file exists
|
| 84 | |
fileexists => sub { return stat($_[0]); },
|
| 85 | |
|
| 86 | |
# do a dns lookup on given value, this also fails if
|
| 87 | |
# no dns is available - so be careful with this
|
| 88 | |
resolvablehost => sub { return gethostbyname($_[0]); },
|
| 89 | |
|
| 90 | |
# looks if the given value is an existing user on the host system
|
| 91 | |
user => sub { return (getpwnam($_[0]))[0]; },
|
| 92 | |
|
| 93 | |
# same with group
|
| 94 | |
group => sub { return getgrnam($_[0]); },
|
| 95 | |
|
| 96 | |
# int between 0 - 65535
|
| 97 | |
port => sub {
|
| 98 | |
if ( $_[0] =~ /^$port$/ && ($_[0] > 0 && $_[0] < 65535) )
|
| 99 | |
{ return 1; } else { return 0; } },
|
| 100 | |
|
| 101 | |
# variable integer range, use: range(N1 - N2)
|
| 102 | |
range => sub {
|
| 103 | |
if ( defined(is_integer($_[0])) && ($_[0] >= $_[2] && $_[0] <= $_[3]) )
|
| 104 | |
{ return 1; } else { return 0; } },
|
| 105 | |
|
| 106 | |
# just a place holder at make the key exist
|
| 107 | |
optional => 1,
|
| 108 | |
);
|
|
34 |
# primitives
|
|
35 |
int => sub { return defined(is_integer($_[0])); },
|
|
36 |
hex => sub { return defined(is_hex($_[0])); },
|
|
37 |
oct => sub { return defined(is_oct($_[0])); },
|
|
38 |
number => sub { return defined(is_numeric($_[0])); },
|
|
39 |
|
|
40 |
word => qr(^[\w_\-]+$),
|
|
41 |
line => qr/^[^\n]+$/s,
|
|
42 |
|
|
43 |
text => sub { return defined(is_printable($_[0])); },
|
|
44 |
|
|
45 |
regex => sub {
|
|
46 |
my $r = ref $_[0];
|
|
47 |
return 1 if $r eq 'Regexp';
|
|
48 |
if ($r eq '') {
|
|
49 |
# this is a bit loosy but should match most regular expressions
|
|
50 |
# using the qr() operator, but it doesn't check if the expression
|
|
51 |
# is valid. we could do this by compiling it, but this would lead
|
|
52 |
# to exploitation possiblities to programs using the module.
|
|
53 |
return $_[0] =~ qr/^qr ( (.).*\1 | \(.*\) | \{.*\} ) $/x;
|
|
54 |
}
|
|
55 |
return 0;
|
|
56 |
},
|
|
57 |
|
|
58 |
# via imported regexes
|
|
59 |
uri => qr(^$RE{URI}$),
|
|
60 |
cidrv4 => sub {
|
|
61 |
my ($p, $l) = split(/\//, $_[0]);
|
|
62 |
return defined(is_ipv4($p)) && defined(is_between($l, 0, 32));
|
|
63 |
},
|
|
64 |
ipv4 => sub { defined(is_ipv4($_[0])) },
|
|
65 |
quoted => qr/^$RE{delimited}{ -delim => qr(\') }$/,
|
|
66 |
hostname => qr(^$host$),
|
|
67 |
|
|
68 |
ipv6 => sub { defined(is_ipv6($_[0])) },
|
|
69 |
cidrv6 => sub {
|
|
70 |
my ($p, $l) = split('/', $_[0]);
|
|
71 |
return defined(is_ipv6($p)) && defined(is_between($l, 0, 128));
|
|
72 |
},
|
|
73 |
|
|
74 |
# matches perl style scalar variables
|
|
75 |
# possible matches: $var ${var} $(var)
|
|
76 |
vars => qr/(?<!\\) ( \$\w+ | \$\{[^\}]+\} | \$\([^\)]+\) )/x,
|
|
77 |
|
|
78 |
# closures
|
|
79 |
|
|
80 |
# this one doesn't do a stat() syscall, so keep cool
|
|
81 |
path => sub { return file_name_is_absolute($_[0]); },
|
|
82 |
|
|
83 |
# though this one does it - it stat()s if the file exists
|
|
84 |
fileexists => sub { return stat($_[0]); },
|
|
85 |
|
|
86 |
# do a dns lookup on given value, this also fails if
|
|
87 |
# no dns is available - so be careful with this
|
|
88 |
resolvablehost => sub { return gethostbyname($_[0]); },
|
|
89 |
|
|
90 |
# looks if the given value is an existing user on the host system
|
|
91 |
user => sub { return (getpwnam($_[0]))[0]; },
|
|
92 |
|
|
93 |
# same with group
|
|
94 |
group => sub { return getgrnam($_[0]); },
|
|
95 |
|
|
96 |
# int between 0 - 65535
|
|
97 |
port => sub {
|
|
98 |
if ( $_[0] =~ /^$port$/ && ($_[0] > 0 && $_[0] < 65535) )
|
|
99 |
{ return 1; } else { return 0; } },
|
|
100 |
|
|
101 |
# variable integer range, use: range(N1 - N2)
|
|
102 |
range => sub {
|
|
103 |
if ( defined(is_integer($_[0])) && ($_[0] >= $_[2] && $_[0] <= $_[3]) )
|
|
104 |
{ return 1; } else { return 0; } },
|
|
105 |
|
|
106 |
# just a place holder at make the key exist
|
|
107 |
optional => 1,
|
|
108 |
);
|
| 109 | 109 |
|
| 110 | 110 |
sub add_validators {
|
| 111 | 111 |
# class method, add validators globally, not per object
|
|
| 556 | 556 |
|
| 557 | 557 |
In some rare situations you might require a negative match. So
|
| 558 | 558 |
a test shall return TRUE if a particular value does NOT match the
|
| 559 | |
given type. This might be usefull to prevent certain things.
|
|
559 |
given type. This might be useful to prevent certain things.
|
| 560 | 560 |
|
| 561 | 561 |
To achieve this, you just have to prepend one of the below mentioned
|
| 562 | 562 |
types with the keyword B<no>.
|
|
| 678 | 678 |
Returns an array ref with the errors found when validating the hash.
|
| 679 | 679 |
Each error is on the format '<value> doesn't match <types> at <ref>',
|
| 680 | 680 |
where <ref> is a comma separated tree view depicting where in the
|
| 681 | |
the error occured.
|
|
681 |
the error occurred.
|
| 682 | 682 |
|
| 683 | 683 |
=item B<errstr()>
|
| 684 | 684 |
|
|
| 898 | 898 |
|
| 899 | 899 |
=head1 VERSION
|
| 900 | 900 |
|
| 901 | |
0.10
|
|
901 |
0.11
|
| 902 | 902 |
|
| 903 | 903 |
=cut
|
| 904 | 904 |
|