scip/Data-Validate-Struct
1
0
Fork 0
mirror of https://codeberg.org/scip/Data-Validate-Struct.git synced 2025-12-17 04:31:01 +01:00
Code Issues Packages Projects Releases Wiki Activity

applied patches by @hemmop

Browse Source
This commit is contained in:
git@daemon.de
2014-11-05 18:28:08 +01:00
parent 8f6fec0146
commit ae5817dd17
7 changed files with 571 additions and 347 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
Changelog
View File

@@ -1,3 +1,15 @@
0.08
o applied patches by Per Carlson:
- don't die on 1st error, rather collect them and
and issue a full report
- use errors() to retrieve all those collected errors
- enhanced unit tests
- proper utf8 handling
- lots of minor tweaks (typos, ambuities and such)
0.07
o lost [updated 11/2014]
0.06 0.06
o fixed t/run.t, it used still the old name, all tests o fixed t/run.t, it used still the old name, all tests
failed therefore. failed therefore.

43
META.json Normal file
View File

@@ -0,0 +1,43 @@
{
"abstract" : "unknown",
"author" : [
"unknown"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.120630",
"license" : [
"unknown"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "Data-Validate-Struct",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"Data::Validate" : "0.06",
"Data::Validate::IP" : "0.18",
"Regexp::Common" : "0"
}
}
},
"release_status" : "stable",
"version" : "0.08"
}

33
META.yml
View File

@@ -1,11 +1,24 @@
# http://module-build.sourceforge.net/META-spec.html ---
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# abstract: unknown
name: Data-Validate-Struct author:
version: 0.05 - unknown
version_from: Struct.pm build_requires:
installdirs: site ExtUtils::MakeMaker: 0
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.120630'
license: unknown
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: Data-Validate-Struct
no_index:
directory:
- t
- inc
requires: requires:
Regexp::Common: Data::Validate: 0.06
Data::Validate::IP: 0.18
distribution_type: module Regexp::Common: 0
generated_by: ExtUtils::MakeMaker version 6.17 version: 0.08

2
Makefile.PL
View File

@@ -1,7 +1,7 @@
# #
# Makefile.PL - build file for Date::Validate::Struct # Makefile.PL - build file for Date::Validate::Struct
# #
# Copyright (c) 2007-2013 Thomas Linden <tom |AT| cpan.org>. # Copyright (c) 2007-2014 T. v.Dein <tom |AT| cpan.org>.
# All Rights Reserved. Std. disclaimer applies. # All Rights Reserved. Std. disclaimer applies.
# Artificial License, same as perl itself. Have fun. # Artificial License, same as perl itself. Have fun.
# #

146
README
View File

@@ -47,9 +47,9 @@ PREDEFINED BUILTIN DATA TYPES
regex regex
Match a perl regex using the operator qr(). Valid examples include: Match a perl regex using the operator qr(). Valid examples include:
qr/[0-9]+/ qr/[0-9]+/
qr([^%]*) qr([^%]*)
qr{\w+(\d+?)} qr{\w+(\d+?)}
Please note, that this doesn't mean you can provide here a regex Please note, that this doesn't mean you can provide here a regex
against config options must match. against config options must match.
@@ -58,9 +58,9 @@ PREDEFINED BUILTIN DATA TYPES
eg: eg:
<cfg> $cfg = {
grp = qr/root|wheel/ grp = qr/root|wheel/
</cfg> };
regex would match the content of the variable 'grp' in this example. regex would match the content of the variable 'grp' in this example.
@@ -75,11 +75,11 @@ PREDEFINED BUILTIN DATA TYPES
cidrv4 cidrv4
The same as above including cidr netmask (/24), IPv4 only, eg: The same as above including cidr netmask (/24), IPv4 only, eg:
10.2.123.0/23 10.2.123.0/23
Note: shortcuts are not supported for the moment, eg: Note: shortcuts are not supported for the moment, eg:
10.10/16 10.10/16
will fail while it is still a valid IPv4 cidr notation for a network will fail while it is still a valid IPv4 cidr notation for a network
address (short for 10.10.0.0/16). Must be fixed in Regex::Common. address (short for 10.10.0.0/16). Must be fixed in Regex::Common.
@@ -87,22 +87,22 @@ PREDEFINED BUILTIN DATA TYPES
ipv6 ipv6
Match an IPv6 address. Some examples: Match an IPv6 address. Some examples:
3ffe:1900:4545:3:200:f8ff:fe21:67cf 3ffe:1900:4545:3:200:f8ff:fe21:67cf
fe80:0:0:0:200:f8ff:fe21:67cf fe80:0:0:0:200:f8ff:fe21:67cf
fe80::200:f8ff:fe21:67cf fe80::200:f8ff:fe21:67cf
ff02:0:0:0:0:0:0:1 ff02:0:0:0:0:0:0:1
ff02::1 ff02::1
cidrv6 cidrv6
The same as above including cidr netmask (/64), IPv6 only, eg: The same as above including cidr netmask (/64), IPv6 only, eg:
2001:db8:dead:beef::1/64 2001:db8:dead:beef::1/64
2001:db8::/32 2001:db8::/32
quoted quoted
Match a text quoted with single quotes, eg: Match a text quoted with single quotes, eg:
'barbara is sexy' 'barbara is sexy'
hostname hostname
Match a valid hostname, it must qualify to the definitions in RFC Match a valid hostname, it must qualify to the definitions in RFC
@@ -116,7 +116,7 @@ PREDEFINED BUILTIN DATA TYPES
Match a valid absolute path, it won't do a stat() system call. This Match a valid absolute path, it won't do a stat() system call. This
will work on any operating system at runtime. So this one: will work on any operating system at runtime. So this one:
C:\Temp C:\Temp
will return TRUE if running on WIN32, but FALSE on FreeBSD! will return TRUE if running on WIN32, but FALSE on FreeBSD!
@@ -138,13 +138,13 @@ PREDEFINED BUILTIN DATA TYPES
Matches a string of text containing variables (perl style variables Matches a string of text containing variables (perl style variables
though) eg: though) eg:
$user is $attribute $user is $attribute
I am $(years) old I am $(years) old
Missing ${points} points to succeed Missing ${points} points to succeed
MIXED TYPES MIXED TYPES
If there is an element which could match more than one type, this can be If there is an element which could match more than one type, this can be
matched by using the pipe sign `|' to separate the types. matched by using the pipe sign "|" to separate the types.
{ name => 'int | number' } { name => 'int | number' }
@@ -187,19 +187,19 @@ VALIDATOR STRUCTURE
Example: Example:
$reference = { user => 'word', uid => 'int' }; $reference = { user => 'word', uid => 'int' };
The following config would be validated successful: The following config would be validated successful:
$config = { user => 'HansDampf', uid => 92 }; $config = { user => 'HansDampf', uid => 92 };
this one not: this one not:
$config = { user => 'Hans Dampf', uid => 'nine' }; $config = { user => 'Hans Dampf', uid => 'nine' };
^ ^^^^ ^ ^^^^
| | | |
| +----- is not a number | +----- is not a number
+---------------------- space not allowed +---------------------- space not allowed
For easier writing of references you yould use a configuration file For easier writing of references you yould use a configuration file
parser like Config::General or Config::Any, just write the definition parser like Config::General or Config::Any, just write the definition
@@ -216,38 +216,38 @@ NESTED HASH STRUCTURES
Given the following reference hash: Given the following reference hash:
$ref = { $ref = {
'b1' => { 'b1' => {
'b2' => { 'b2' => {
'b3' => { 'b3' => {
'item' => 'int' 'item' => 'int'
} }
}
} }
} }
}
Now if you validate it against the following config hash it will return Now if you validate it against the following config hash it will return
TRUE: TRUE:
$cfg = { $cfg = {
'b1' => { 'b1' => {
'b2' => { 'b2' => {
'b3' => { 'b3' => {
'item' => '100' 'item' => '100'
} }
} }
} }
} }
If you validate it for example against this hash, it will return FALSE: If you validate it for example against this hash, it will return FALSE:
$cfg = { $cfg = {
'b1' => { 'b1' => {
'b2' => { 'b2' => {
'item' => '100' 'item' => '100'
} }
} }
} }
SUBROUTINES/METHODS SUBROUTINES/METHODS
validate($config) validate($config)
@@ -265,22 +265,15 @@ SUBROUTINES/METHODS
Example: Example:
$v3->type( $v3->type(
( address => qr(^\w+\s\s*\d+$),
address => qr(^\w+\s\s*\d+$),
list => list => sub {
sub { my $list = shift;
my $list = $_[0];
my @list = split /\s*,\s*/, $list; my @list = split /\s*,\s*/, $list;
if (scalar @list > 1) { return scalar @list > 1;
return 1; },
} );
else {
return 0;
}
}
)
);
In this example we add 2 new types, 'list' and 'address', which are In this example we add 2 new types, 'list' and 'address', which are
really simple. 'address' is a regex which matches a word followed by really simple. 'address' is a regex which matches a word followed by
@@ -291,19 +284,28 @@ SUBROUTINES/METHODS
match. match.
A negative/reverse match is automatically added as well, see A negative/reverse match is automatically added as well, see
NEGATIVE MATCHING. "NEGATIVE MATCHING".
Regexes will be executed exactly as given. No flags or ^ or $ will Regexes will be executed exactly as given. No flags or ^ or $ will
be used by the module. Eg. if you want to match the whole value from be used by the module. Eg. if you want to match the whole value from
beginning to the end, add ^ and $, like you can see in our 'address' beginning to the end, add ^ and $, like you can see in our 'address'
example above. example above.
"type" do accept either a hash (%hash), a hash ref (%$hash) or a
list of key/values ("key => value") as input.
debug() debug()
Enables debug output which gets printed to STDERR. Enables debug output which gets printed to STDERR.
errors
Returns an array ref with the errors found when validating the hash.
Each error is on the format '<value> doesn't match <types> at
<ref>', where <ref> is a comma separated tree view depicting where
in the the error occured.
errstr() errstr()
Returns the last error, which is useful to notify the user about Returns the last error, which is useful to notify the user about
what happened. what happened. The format is like in "errors".
EXAMPLES EXAMPLES
Take a look to t/run.t for lots of examples. Take a look to t/run.t for lots of examples.
@@ -328,7 +330,7 @@ SEE ALSO
Data::Validate::IP common data validation methods for IP-addresses. Data::Validate::IP common data validation methods for IP-addresses.
LICENSE AND COPYRIGHT LICENSE AND COPYRIGHT
Copyright (c) 2007-2013 Thomas Linden Copyright (c) 2007-2014 T. v.Dein
This library is free software; you can redistribute it and/or modify it This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. under the same terms as Perl itself.
@@ -338,7 +340,7 @@ BUGS AND LIMITATIONS
This will no more happen if entering a stable release (starting with This will no more happen if entering a stable release (starting with
1.00). 1.00).
To submit use http://rt.cpan.org. To submit use <http://rt.cpan.org>.
INCOMPATIBILITIES INCOMPATIBILITIES
None known. None known.
@@ -373,11 +375,13 @@ TODO
or something like this. or something like this.
AUTHOR AUTHORS
Thomas Linden <tlinden |AT| cpan.org> T. v.Dein <tlinden |AT| cpan.org>
Per Carlson <pelle |AT| hemmop.com>
Thanks to David Cantrell for his helpful hints. Thanks to David Cantrell for his helpful hints.
VERSION VERSION
0.07 0.08

334
Struct.pm
View File

@@ -1,5 +1,5 @@
# #
# Copyright (c) 2007-2013 Thomas Linden <tlinden |AT| cpan.org>. # Copyright (c) 2007-2014 T. v.Dein <tlinden |AT| cpan.org>.
# All Rights Reserved. Std. disclaimer applies. # All Rights Reserved. Std. disclaimer applies.
# Artificial License, same as perl itself. Have fun. # Artificial License, same as perl itself. Have fun.
# #
@@ -11,7 +11,7 @@ use warnings;
use English '-no_match_vars'; use English '-no_match_vars';
use Carp; use Carp;
use Exporter; use Exporter;
use Encode qw{ encode };
use Regexp::Common::URI::RFC2396 qw /$host $port/; use Regexp::Common::URI::RFC2396 qw /$host $port/;
use Regexp::Common qw /URI net delimited/; use Regexp::Common qw /URI net delimited/;
@@ -21,21 +21,18 @@ use File::stat;
use Data::Validate qw(:math is_printable); use Data::Validate qw(:math is_printable);
use Data::Validate::IP qw(is_ipv4 is_ipv6); use Data::Validate::IP qw(is_ipv4 is_ipv6);
use constant FALSE => 0; our $VERSION = 0.08;
use constant TRUE => 1;
our $VERSION = 0.07;
use vars qw(@ISA); use vars qw(@ISA);
sub new { sub new {
my( $this, $structure ) = @_; my ($class, $structure) = @_;
my $class = ref($this) || $this; $class = ref($class) || $class;
my $self = bless {}, $class;
my $self;
$self->{structure} = $structure; $self->{structure} = $structure;
#
# if types will be implemented in Data::Validate, remove our own # if types will be implemented in Data::Validate, remove our own
# types from here and use Data::Validate's methods as subroutine # types from here and use Data::Validate's methods as subroutine
# checks, which we already support. # checks, which we already support.
@@ -112,138 +109,164 @@ sub new {
}; };
$self->{debug} = 0; $self->{debug} = 0;
$self->{errors} = [];
foreach my $type (%{$self->{types}}) { foreach my $type (%{$self->{types}}) {
# add negative match types # add negative match types
$self->{types}->{'no' . $type} = $self->{types}->{$type}; $self->{types}->{'no' . $type} = $self->{types}->{$type};
} }
bless $self, $class;
return $self; return $self;
} }
sub type {
my ($this, %param) = @_;
foreach my $type (keys %param) {
$this->{types}->{$type} = $param{$type};
# add negative match types
$this->{types}->{'no' . $type} = $param{$type};
}
}
sub debug { sub debug {
my ($this) = @_; shift->{debug} = 1;
$this->{debug} = 1;
} }
sub errors {
my $self = shift;
return $self->{errors};
}
sub errstr { sub errstr {
my ($this) = @_; my $self = shift;
if (exists $this->{error}) { return $self->{errors} ? $self->{errors}->[0] : '';
return $this->{error}; }
sub type {
my $self = shift;
return unless @_;
my $param = @_ > 1 ? {@_} : {%{$_[0]}};
foreach my $type (keys %$param) {
$self->{types}->{$type} = $param->{$type};
# add negative match types
$self->{types}->{'no' . $type} = $param->{$type};
} }
} }
sub validate { sub validate {
my($this, $config) = @_; my ($self, $config) = @_;
eval { $self->_traverse($self->{structure}, $config, ());
$this->traverse($this->{structure}, $config); # return TRUE if no errors
}; return scalar @{ $self->{errors} } == 0;
if ($@) {
$this->{error} = $@;
return FALSE;
}
else {
return TRUE;
}
} }
# Private methods
sub _debug { sub _debug {
my ($this, $msg) = @_; my ($self, $msg) = @_;
if ($this->{debug}) { if ($self->{debug}) {
print STDERR "D::V::S::debug() - $msg\n"; print STDERR "D::V::S::debug() - $msg\n";
} }
} }
sub traverse { sub _traverse {
my($this, $reference, $hash) = @_; my ($self, $reference, $hash, @tree) = @_;
foreach my $key (keys %{$reference}) { foreach my $key (keys %{$reference}) {
if (ref($reference->{$key}) eq 'ARRAY') { if (ref($reference->{$key}) eq 'ARRAY') {
# just use the 1st one, more elements in array are expected to be the same # just use the 1st one, more elements in array are expected to be the same
foreach my $item (@{$hash->{$key}}) { foreach my $item (@{$hash->{$key}}) {
if (ref($item) eq q(HASH)) { if (ref($item) eq q(HASH)) {
$this->traverse($reference->{$key}->[0], $item); # traverse the structure pushing our key to the @tree
} $self->_traverse($reference->{$key}->[0], $item, @tree, $key);
else { }
# a value, this is tricky else {
$this->traverse({item => $reference->{$key}->[0]}, { item => $item}); # a value, this is tricky
} $self->_traverse(
{ item => $reference->{$key}->[0] },
{ item => $item },
@tree, $key
);
}
} }
} }
elsif (ref($reference->{$key}) eq 'HASH') { elsif (ref($reference->{$key}) eq 'HASH') {
$this->traverse($reference->{$key}, $hash->{$key}); $self->_traverse($reference->{$key}, $hash->{$key}, @tree, $key);
} }
elsif (ref($reference->{$key}) eq '') { elsif (ref($reference->{$key}) eq '') {
my @types = _trim( (split /\|/, $reference->{$key}) ); $self->_debug("Checking $key at " . join(', ', @tree));
# check data types if (my $err = $self->_check_type($key, $reference, $hash)) {
if (grep { ! exists $this->{types}->{$_} } @types) { push @{$self->{errors}}, sprintf(q{%s at '%s'}, $err, join(' => ', @tree));
croak qq(Invalid data type in "$reference->{$key}");
} }
else {
if (exists $hash->{$key}) {
$this->check_type(\@types, $key, $hash->{$key});
}
elsif (grep { $_ eq 'optional' } @types) {
# do nothing
$this->_debug("$key is optional");
}
else {
die "required $key doesn't exist in hash\n";
}
}
} else {
croak "Invalid data type '$reference->{$key}: " . ref($reference->{$key});
} }
} }
} }
sub check_type { sub _check_type {
my($this, $types, $name, $value) = @_; my ($self, $key, $reference, $hash) = @_;
my @types = _trim( (split /\|/, $reference->{$key}) );
# check data types
if (grep { ! exists $self->{types}->{$_} } @types) {
return "Invalid data type '$reference->{$key}'";
}
# does $key exist in $hash
unless (exists $hash->{$key}) {
# is it an optional key?
if (grep { $_ eq 'optional' } @types) {
# do nothing
$self->_debug("$key is optional");
return;
}
else {
# report error
return "Required key '$key' is missing";
}
}
# the value in $hash->{$key} (shortcut)
my $value = $hash->{$key};
# the aggregated match over *all* types # the aggregated match over *all* types
my $match = 0; my $match = 0;
foreach my $type (@$types) { foreach my $type (@types) {
# skip optional data type (can't be compared)
next if $type eq 'optional'; next if $type eq 'optional';
# if the type begins with 'no' AND the remainder of the type # if the type begins with 'no' AND the remainder of the type
# also exists in the type hash, we are expects something that is # also exists in the type hash, we are expects something that is
# FALSE (0), else TRUE (0). # FALSE (0), else TRUE (1).
# we must check for both, if not we will get a false match on a type # we must check for both, if not we will get a false match on a type
# called 'nothing'. # called 'nothing'.
my $expects = TRUE; my $expects = 1;
if ($type =~ /^no(.*)/) { if ($type =~ /^no(.*)/) {
$expects = FALSE if exists $this->{types}->{$1}; $expects = 0 if exists $self->{types}->{$1};
} }
my $result = ref($this->{types}->{$type}) eq q(CODE) # "Evaluate" this $type. We set $result explicitly to 1 or 0
? &{$this->{types}->{$type}}($value) ? TRUE : FALSE # execute closure # instead of relying the coderef returning a proper value.
: $value =~ /$this->{types}->{$type}/ ? TRUE : FALSE; # This makes comparing $expects and $result mush easier, no magic
# type conversions are needed.
my $result = ref($self->{types}->{$type}) eq q(CODE)
# the the type is a code ref, execute the code
? &{$self->{types}->{$type}}($value) ? 1 : 0
# else it's an regexp, check if it's a match
: $value =~ /$self->{types}->{$type}/ ? 1 : 0;
$this->_debug(sprintf( $self->_debug(sprintf(
"%s = %s, value %s %s", $name, $value, $result ? 'is' : 'is not', $type '%s = %s, value %s %s',
$key,
encode('UTF-8', $value),
$result ? 'is' : 'is not',
$type
)); ));
$match ||= ($expects == $result); $match ||= ($expects == $result);
} }
# die if it doesn't match return if $match;
die("$name = $value, value doesn't match " . join(' | ', @$types)) unless $match;
# else return gracefully return sprintf q{'%s' doesn't match '%s'},
return; encode('UTF-8', $value), $reference->{$key};
} }
@@ -330,9 +353,9 @@ is very loosy, consider it as an alias to B<any>.
Match a perl regex using the operator qr(). Valid examples include: Match a perl regex using the operator qr(). Valid examples include:
qr/[0-9]+/ qr/[0-9]+/
qr([^%]*) qr([^%]*)
qr{\w+(\d+?)} qr{\w+(\d+?)}
Please note, that this doesn't mean you can provide Please note, that this doesn't mean you can provide
here a regex against config options must match. here a regex against config options must match.
@@ -341,9 +364,9 @@ Instead this means that the config options contains a regex.
eg: eg:
<cfg> $cfg = {
grp = qr/root|wheel/ grp = qr/root|wheel/
</cfg> };
B<regex> would match the content of the variable 'grp' B<regex> would match the content of the variable 'grp'
in this example. in this example.
@@ -363,11 +386,11 @@ Match an IPv4 address.
The same as above including cidr netmask (/24), IPv4 only, eg: The same as above including cidr netmask (/24), IPv4 only, eg:
10.2.123.0/23 10.2.123.0/23
Note: shortcuts are not supported for the moment, eg: Note: shortcuts are not supported for the moment, eg:
10.10/16 10.10/16
will fail while it is still a valid IPv4 cidr notation for will fail while it is still a valid IPv4 cidr notation for
a network address (short for 10.10.0.0/16). Must be fixed a network address (short for 10.10.0.0/16). Must be fixed
@@ -377,24 +400,24 @@ in L<Regex::Common>.
Match an IPv6 address. Some examples: Match an IPv6 address. Some examples:
3ffe:1900:4545:3:200:f8ff:fe21:67cf 3ffe:1900:4545:3:200:f8ff:fe21:67cf
fe80:0:0:0:200:f8ff:fe21:67cf fe80:0:0:0:200:f8ff:fe21:67cf
fe80::200:f8ff:fe21:67cf fe80::200:f8ff:fe21:67cf
ff02:0:0:0:0:0:0:1 ff02:0:0:0:0:0:0:1
ff02::1 ff02::1
=item B<cidrv6> =item B<cidrv6>
The same as above including cidr netmask (/64), IPv6 only, eg: The same as above including cidr netmask (/64), IPv6 only, eg:
2001:db8:dead:beef::1/64 2001:db8:dead:beef::1/64
2001:db8::/32 2001:db8::/32
=item B<quoted> =item B<quoted>
Match a text quoted with single quotes, eg: Match a text quoted with single quotes, eg:
'barbara is sexy' 'barbara is sexy'
=item B<hostname> =item B<hostname>
@@ -411,7 +434,7 @@ dns is available at runtime.
Match a valid absolute path, it won't do a stat() system call. Match a valid absolute path, it won't do a stat() system call.
This will work on any operating system at runtime. So this one: This will work on any operating system at runtime. So this one:
C:\Temp C:\Temp
will return TRUE if running on WIN32, but FALSE on FreeBSD! will return TRUE if running on WIN32, but FALSE on FreeBSD!
@@ -436,9 +459,9 @@ Match a valid tcp/udp port. Must be a digit between 0 and 65535.
Matches a string of text containing variables (perl style variables though) Matches a string of text containing variables (perl style variables though)
eg: eg:
$user is $attribute $user is $attribute
I am $(years) old I am $(years) old
Missing ${points} points to succeed Missing ${points} points to succeed
=back =back
@@ -496,19 +519,19 @@ hash.
Example: Example:
$reference = { user => 'word', uid => 'int' }; $reference = { user => 'word', uid => 'int' };
The following config would be validated successful: The following config would be validated successful:
$config = { user => 'HansDampf', uid => 92 }; $config = { user => 'HansDampf', uid => 92 };
this one not: this one not:
$config = { user => 'Hans Dampf', uid => 'nine' }; $config = { user => 'Hans Dampf', uid => 'nine' };
^ ^^^^ ^ ^^^^
| | | |
| +----- is not a number | +----- is not a number
+---------------------- space not allowed +---------------------- space not allowed
For easier writing of references you yould use a configuration For easier writing of references you yould use a configuration
file parser like Config::General or Config::Any, just write the file parser like Config::General or Config::Any, just write the
@@ -525,39 +548,39 @@ throw an error, which B<Data::Validate::Struct> catches and returns FALSE.
Given the following reference hash: Given the following reference hash:
$ref = { $ref = {
'b1' => { 'b1' => {
'b2' => { 'b2' => {
'b3' => { 'b3' => {
'item' => 'int' 'item' => 'int'
} }
}
} }
} }
}
Now if you validate it against the following config hash it Now if you validate it against the following config hash it
will return TRUE: will return TRUE:
$cfg = { $cfg = {
'b1' => { 'b1' => {
'b2' => { 'b2' => {
'b3' => { 'b3' => {
'item' => '100' 'item' => '100'
} }
} }
} }
} }
If you validate it for example against this hash, it will If you validate it for example against this hash, it will
return FALSE: return FALSE:
$cfg = { $cfg = {
'b1' => { 'b1' => {
'b2' => { 'b2' => {
'item' => '100' 'item' => '100'
} }
} }
} }
=head1 SUBROUTINES/METHODS =head1 SUBROUTINES/METHODS
@@ -580,22 +603,15 @@ method. Values in this hash can be regexes or anonymous subs.
Example: Example:
$v3->type( $v3->type(
( address => qr(^\w+\s\s*\d+$),
address => qr(^\w+\s\s*\d+$),
list => list => sub {
sub { my $list = shift;
my $list = $_[0];
my @list = split /\s*,\s*/, $list; my @list = split /\s*,\s*/, $list;
if (scalar @list > 1) { return scalar @list > 1;
return 1; },
} );
else {
return 0;
}
}
)
);
In this example we add 2 new types, 'list' and 'address', which In this example we add 2 new types, 'list' and 'address', which
are really simple. 'address' is a regex which matches a word are really simple. 'address' is a regex which matches a word
@@ -612,14 +628,24 @@ will be used by the module. Eg. if you want to match the whole
value from beginning to the end, add ^ and $, like you can see value from beginning to the end, add ^ and $, like you can see
in our 'address' example above. in our 'address' example above.
C<type> do accept either a hash (C<%hash>), a hash ref (C<%$hash>) or a
list of key/values (C<< key => value >>) as input.
=item B<debug()> =item B<debug()>
Enables debug output which gets printed to STDERR. Enables debug output which gets printed to STDERR.
=item B<errors>
Returns an array ref with the errors found when validating the hash.
Each error is on the format '<value> doesn't match <types> at <ref>',
where <ref> is a comma separated tree view depicting where in the
the error occured.
=item B<errstr()> =item B<errstr()>
Returns the last error, which is useful to notify the user Returns the last error, which is useful to notify the user
about what happened. about what happened. The format is like in L</errors>.
=back =back
@@ -649,7 +675,7 @@ L<Data::Validate::IP> common data validation methods for IP-addresses.
=head1 LICENSE AND COPYRIGHT =head1 LICENSE AND COPYRIGHT
Copyright (c) 2007-2013 Thomas Linden Copyright (c) 2007-2014 T. v.Dein
This library is free software; you can redistribute it and/or This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. modify it under the same terms as Perl itself.
@@ -710,15 +736,17 @@ or something like this.
=back =back
=head1 AUTHOR =head1 AUTHORS
Thomas Linden <tlinden |AT| cpan.org> T. v.Dein <tlinden |AT| cpan.org>
Per Carlson <pelle |AT| hemmop.com>
Thanks to David Cantrell for his helpful hints. Thanks to David Cantrell for his helpful hints.
=head1 VERSION =head1 VERSION
0.07 0.08
=cut =cut

348
t/run.t
View File

@@ -1,5 +1,7 @@
# -*-perl-*- # -*-perl-*-
use utf8;
use Test::More; use Test::More;
use Encode qw{ encode };
require_ok( 'Data::Validate::Struct' ); require_ok( 'Data::Validate::Struct' );
@@ -43,11 +45,17 @@ my $ref = {
'o1' => 'int | optional', 'o1' => 'int | optional',
'AoA' => [ [ 'int' ] ],
'AoH' => [ 'AoH' => [
{ fullname => 'text', user => 'word', uid => 'int' } { fullname => 'text', user => 'word', uid => 'int' }
], ],
'AoA' => [ [ 'int' ] ], 'HoH' => {
father => { fullname => 'text', user => 'word' },
son => { fullname => 'text', user => 'word' },
daughter => { fullname => 'text', user => 'word' },
},
}; };
my $cfg = { my $cfg = {
@@ -93,120 +101,217 @@ my $cfg = {
'v27' => '10', 'v27' => '10',
'v28' => '$ten', 'v28' => '$ten',
'AoH' => [
{ fullname => 'Homer Simpson', user => 'homer', uid => 100 },
{ fullname => 'Bart Simpson', user => 'bart', uid => 101 },
{ fullname => 'Lisa Simpson', user => 'lisa', uid => 102 },
],
'AoA' => [ 'AoA' => [
[ qw{ 10 11 12 13 } ], [ qw{ 10 11 12 13 } ],
[ qw{ 20 21 22 23 } ], [ qw{ 20 21 22 23 } ],
[ qw{ 30 31 32 33 } ], [ qw{ 30 31 32 33 } ],
], ],
'AoH' => [
{ fullname => 'Homer Simpson', user => 'homer', uid => 100 },
{ fullname => 'Bart Simpson', user => 'bart', uid => 101 },
{ fullname => 'Lisa Simpson', user => 'lisa', uid => 102 },
],
'HoH' => {
father => { fullname => 'Homer Simpson', user => 'homer' },
son => { fullname => 'Bart Simpson', user => 'bart' },
daughter => { fullname => 'Lisa Simpson', user => 'lisa' },
},
}; };
my $v = new_ok('Data::Validate::Struct', [ $ref ]); my $v = new_ok('Data::Validate::Struct', [ $ref ]);
ok ($v->validate($cfg), "validate a reference against a config " . $v->errstr()); ok ($v->validate($cfg), "validate a reference against a OK config");
# check failure matching # check failure matching
my @failure = my @failure = (
( {
{ cfg => q(acht), cfg => q(acht),
type => q(int) type => q(int),
}, descr => 'int',
errors => 1,
{ cfg => q(27^8),
type => q(number)
},
{ cfg => q(two words),
type => q(word)
},
{ cfg => qq(<<EOF\nzeile1\nzeile2\nzeile3\nEOF\n),
type => q(line)
},
{ cfg => q(<EFBFBD>tz),
type => q(hostname)
},
{ cfg => q(gibtsnet123456790.intern),
type => q(resolvablehost)
},
{ cfg => q(<EFBFBD><EFBFBD><EFBFBD>),
type => q(user)
},
{ cfg => q(<EFBFBD><EFBFBD><EFBFBD>),
type => q(group)
},
{ cfg => q(234234444),
type => q(port)
},
{ cfg => q(unknown:/unsinn<6E><6E><EFBFBD>),
type => q(uri)
},
{ cfg => q(1.1.1.1/33),
type => q(cidrv4)
},
{ cfg => q(300.1.1.1),
type => q(ipv4)
},
{ cfg => q(<EFBFBD><EFBFBD><EFBFBD>),
type => q(fileexists)
},
{ cfg => q(not quoted),
type => q(quoted)
},
{ cfg => q(no regex),
type => q(regex)
},
{ cfg => q($contains some $vars),
type => q(novars)
},
{ cfg => q(2001:db8::dead::beef),
type => q(ipv6)
},
{ cfg => q(2001:db8:dead:beef::1/129),
type => q(cidrv6)
}, },
{ {
cfg => [ cfg => q(27^8),
{ fullname => 'Homer Simpson', user => 'homer', uid => 100 }, type => q(number),
{ fullname => 'Bart Simpson', user => 'bart', uid => 101 }, descr => 'number',
{ fullname => 'Lisa Simpson', user => 'lisa:', uid => 102 }, errors => 1,
], },
type => [ {
{ fullname => 'text', user => 'word', uid => 'int' } cfg => q(two words),
], type => q(word),
descr => 'word',
errors => 1,
},
{
cfg => qq(<<EOF\nzeile1\nzeile2\nzeile3\nEOF\n),
type => q(line),
descr => 'line',
errors => 1,
},
{
cfg => q(ätz),
type => q(hostname),
descr => 'hostname',
errors => 1,
},
{
cfg => q(gibtsnet123456790.intern),
type => q(resolvablehost),
descr => 'resolvablehost',
errors => 1,
},
{
cfg => q(äüö),
type => q(user),
descr => 'user',
errors => 1,
},
{
cfg => q(äüö),
type => q(group),
descr => 'group',
errors => 1,
},
{
cfg => q(234234444),
type => q(port),
descr => 'port',
errors => 1,
},
{
cfg => q(unknown:/unsinnüäö),
type => q(uri),
descr => 'uri',
errors => 1,
},
{
cfg => q(1.1.1.1/33),
type => q(cidrv4),
descr => 'cidrv4',
errors => 1,
},
{
cfg => q(300.1.1.1),
type => q(ipv4),
descr => 'ipv4',
errors => 1,
},
{
cfg => q(üäö),
type => q(fileexists),
descr => 'fileexists',
errors => 1,
},
{
cfg => q(not quoted),
type => q(quoted),
descr => 'quoted',
errors => 1,
},
{
cfg => q(no regex),
type => q(regex),
descr => 'regex',
errors => 1,
},
{
cfg => q($contains some $vars),
type => q(novars),
descr => 'novars',
errors => 1,
},
{
cfg => q(2001:db8::dead::beef),
type => q(ipv6),
descr => 'ipv6',
errors => 1,
},
{
cfg => q(2001:db8:dead:beef::1/129),
type => q(cidrv6),
descr => 'cidrv6',
errors => 1,
}, },
{ {
cfg => [ cfg => [
[ qw{ 10 11 12 13 } ], [ qw{ 10 11 12 13 } ],
[ qw{ 20 21 22 23 } ], [ qw{ 'twenty' 21 22 23 } ],
[ qw{ 30 31 32.0 33 } ], [ qw{ 30 31 32.0 33 } ],
], ],
type => [ [ 'int' ] ], type => [ [ 'int' ] ],
descr => 'array of arrays',
errors => 2,
},
{
cfg => [
{ fullname => 'Homer Simpson', user => 'homer', uid => 100 },
{ fullname => 'Bart Simpson', user => ':bart', uid => 101 },
{ fullname => 'Lisa Simpson', user => 'lisa', uid => '102' },
],
type => [
{ fullname => 'text', user => 'word', uid => 'int' }
],
descr => 'array of hashes',
errors => 1,
},
{
cfg => {
father => { fullname => 'Homer Simpson', user => 'homer', uid => 100 },
son => { fullname => 'Bart Simpson', user => 'bart', uid => 'one hundred one' },
daughter => { fullname => 'Lisa Simpson', user => 'lisa:', uid => 'one hundred two' },
},
type => {
father => { fullname => 'text', user => 'word', uid => 'int' },
son => { fullname => 'text', user => 'word', uid => 'int' },
daughter => { fullname => 'text', user => 'word', uid => 'int' },
},
descr => 'hash of hashes',
errors => 3,
},
{
cfg => {
name => 'Foo Bar',
age => 42,
},
type => {
name => 'text',
age => 'int',
address => 'text',
},
descr => 'Missing required field',
errors => 1,
}, },
); );
@@ -215,49 +320,68 @@ foreach my $test (@failure) {
my $ref = { v => $test->{type} }; my $ref = { v => $test->{type} };
my $cfg = { v => $test->{cfg} }; my $cfg = { v => $test->{cfg} };
my $v = new Data::Validate::Struct($ref); my $v = new Data::Validate::Struct($ref);
if ($v->validate($cfg)) { #$v->debug();
fail("could not catch invalid '$test->{type}'"); my $result = $v->validate($cfg);
my $descr = encode('UTF-8',
exists $test->{descr} ? $test->{descr} : $test->{cfg}
);
my $errors = exists $test->{errors} ? $test->{errors} : 1;
unless ($result) {
is @{$v->errors}, $errors, "Caught failure for '$descr'";
} }
else { else {
pass("catched invalid '$test->{type}'"); fail("Couldn't catch invalid '$test->{descr}'");
} }
} }
# clean old object
undef $v;
$v = Data::Validate::Struct->new({
h1 => { h2 => { item => 'int' } }
});
ok !$v->validate({
h1 => { h2 => { item => 'qux' } }
}), 'item is not an h1 => h2 => int';
is $v->errstr, q{'qux' doesn't match 'int' at 'h1 => h2'}, 'correct error trace';
# adding custom type # adding custom type
my $ref3 = { my $ref3 = {
v1 => 'address', v1 => 'address',
v2 => 'list', v2 => 'list',
v3 => 'noob', v3 => 'noob',
v4 => 'nonoob', v4 => 'nonoob',
}; };
my $cfg3 = { my $cfg3 = {
v1 => 'Marblestreet 15', v1 => 'Marblestreet 15',
v2 => 'a1, b2, b3', v2 => 'a1, b2, b3',
v3 => 42, v3 => 42,
v4 => 43, v4 => 43,
}; };
my $v3 = new Data::Validate::Struct($ref3); my $v3 = new Data::Validate::Struct($ref3);
$v3->type( # add via hash
( note('added via hash');
address => qr(^\w+\s\s*\d+$), my %h = (
list => address => qr(^\w+\s\s*\d+$)
sub {
my $list = $_[0];
my @list = split /\s*,\s*/, $list;
if (scalar @list > 1) {
return 1;
}
else {
return 0;
}
},
noob => sub { return $_[0] == 42 },
)
); );
ok($v3->validate($cfg3), "using custom types " . $v3->errstr()); $v3->type(%h);
# add via hash ref
note('added via hash ref');
$v3->type({ list =>
sub {
my $list = $_[0];
my @list = split /\s*,\s*/, $list;
return scalar @list > 1;
}
});
# add via key => value
note('added via key => val');
$v3->type(noob => sub { return $_[0] == 42 });
ok($v3->validate($cfg3), "using custom types");
done_testing(); done_testing();