scip/Data-Validate-Struct
1
0
Fork 0
mirror of https://codeberg.org/scip/Data-Validate-Struct.git synced 2025-12-16 20:21:02 +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
o fixed t/run.t, it used still the old name, all tests
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#
name: Data-Validate-Struct
version: 0.05
version_from: Struct.pm
installdirs: site
---
abstract: unknown
author:
- unknown
build_requires:
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:
Regexp::Common:
distribution_type: module
generated_by: ExtUtils::MakeMaker version 6.17
Data::Validate: 0.06
Data::Validate::IP: 0.18
Regexp::Common: 0
version: 0.08

2
Makefile.PL
View File

@@ -1,7 +1,7 @@
#
# 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.
# Artificial License, same as perl itself. Have fun.
#

146
README
View File

@@ -47,9 +47,9 @@ PREDEFINED BUILTIN DATA TYPES
regex
Match a perl regex using the operator qr(). Valid examples include:
qr/[0-9]+/
qr([^%]*)
qr{\w+(\d+?)}
qr/[0-9]+/
qr([^%]*)
qr{\w+(\d+?)}
Please note, that this doesn't mean you can provide here a regex
against config options must match.
@@ -58,9 +58,9 @@ PREDEFINED BUILTIN DATA TYPES
eg:
<cfg>
grp = qr/root|wheel/
</cfg>
$cfg = {
grp = qr/root|wheel/
};
regex would match the content of the variable 'grp' in this example.
@@ -75,11 +75,11 @@ PREDEFINED BUILTIN DATA TYPES
cidrv4
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:
10.10/16
10.10/16
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.
@@ -87,22 +87,22 @@ PREDEFINED BUILTIN DATA TYPES
ipv6
Match an IPv6 address. Some examples:
3ffe:1900:4545:3:200:f8ff:fe21:67cf
fe80:0:0:0:200:f8ff:fe21:67cf
fe80::200:f8ff:fe21:67cf
ff02:0:0:0:0:0:0:1
ff02::1
3ffe:1900:4545:3:200:f8ff:fe21:67cf
fe80:0:0:0:200:f8ff:fe21:67cf
fe80::200:f8ff:fe21:67cf
ff02:0:0:0:0:0:0:1
ff02::1
cidrv6
The same as above including cidr netmask (/64), IPv6 only, eg:
2001:db8:dead:beef::1/64
2001:db8::/32
2001:db8:dead:beef::1/64
2001:db8::/32
quoted
Match a text quoted with single quotes, eg:
'barbara is sexy'
'barbara is sexy'
hostname
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
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!
@@ -138,13 +138,13 @@ PREDEFINED BUILTIN DATA TYPES
Matches a string of text containing variables (perl style variables
though) eg:
$user is $attribute
I am $(years) old
Missing ${points} points to succeed
$user is $attribute
I am $(years) old
Missing ${points} points to succeed
MIXED TYPES
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' }
@@ -187,19 +187,19 @@ VALIDATOR STRUCTURE
Example:
$reference = { user => 'word', uid => 'int' };
$reference = { user => 'word', uid => 'int' };
The following config would be validated successful:
$config = { user => 'HansDampf', uid => 92 };
$config = { user => 'HansDampf', uid => 92 };
this one not:
$config = { user => 'Hans Dampf', uid => 'nine' };
^ ^^^^
| |
| +----- is not a number
+---------------------- space not allowed
$config = { user => 'Hans Dampf', uid => 'nine' };
^ ^^^^
| |
| +----- is not a number
+---------------------- space not allowed
For easier writing of references you yould use a configuration file
parser like Config::General or Config::Any, just write the definition
@@ -216,38 +216,38 @@ NESTED HASH STRUCTURES
Given the following reference hash:
$ref = {
'b1' => {
$ref = {
'b1' => {
'b2' => {
'b3' => {
'item' => 'int'
}
}
'b3' => {
'item' => 'int'
}
}
}
}
}
Now if you validate it against the following config hash it will return
TRUE:
$cfg = {
'b1' => {
$cfg = {
'b1' => {
'b2' => {
'b3' => {
'item' => '100'
}
}
}
}
'b3' => {
'item' => '100'
}
}
}
}
If you validate it for example against this hash, it will return FALSE:
$cfg = {
'b1' => {
$cfg = {
'b1' => {
'b2' => {
'item' => '100'
}
}
}
'item' => '100'
}
}
}
SUBROUTINES/METHODS
validate($config)
@@ -265,22 +265,15 @@ SUBROUTINES/METHODS
Example:
$v3->type(
(
address => qr(^\w+\s\s*\d+$),
list =>
sub {
my $list = $_[0];
$v3->type(
address => qr(^\w+\s\s*\d+$),
list => sub {
my $list = shift;
my @list = split /\s*,\s*/, $list;
if (scalar @list > 1) {
return 1;
}
else {
return 0;
}
}
)
);
return scalar @list > 1;
},
);
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
@@ -291,19 +284,28 @@ SUBROUTINES/METHODS
match.
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
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'
example above.
"type" do accept either a hash (%hash), a hash ref (%$hash) or a
list of key/values ("key => value") as input.
debug()
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()
Returns the last error, which is useful to notify the user about
what happened.
what happened. The format is like in "errors".
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.
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
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
1.00).
To submit use http://rt.cpan.org.
To submit use <http://rt.cpan.org>.
INCOMPATIBILITIES
None known.
@@ -373,11 +375,13 @@ TODO
or something like this.
AUTHOR
Thomas Linden <tlinden |AT| cpan.org>
AUTHORS
T. v.Dein <tlinden |AT| cpan.org>
Per Carlson <pelle |AT| hemmop.com>
Thanks to David Cantrell for his helpful hints.
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.
# Artificial License, same as perl itself. Have fun.
#
@@ -11,7 +11,7 @@ use warnings;
use English '-no_match_vars';
use Carp;
use Exporter;
use Encode qw{ encode };
use Regexp::Common::URI::RFC2396 qw /$host $port/;
use Regexp::Common qw /URI net delimited/;
@@ -21,21 +21,18 @@ use File::stat;
use Data::Validate qw(:math is_printable);
use Data::Validate::IP qw(is_ipv4 is_ipv6);
use constant FALSE => 0;
use constant TRUE => 1;
our $VERSION = 0.07;
our $VERSION = 0.08;
use vars qw(@ISA);
sub new {
my( $this, $structure ) = @_;
my $class = ref($this) || $this;
my ($class, $structure) = @_;
$class = ref($class) || $class;
my $self = bless {}, $class;
my $self;
$self->{structure} = $structure;
#
# if types will be implemented in Data::Validate, remove our own
# types from here and use Data::Validate's methods as subroutine
# checks, which we already support.
@@ -112,138 +109,164 @@ sub new {
};
$self->{debug} = 0;
$self->{errors} = [];
foreach my $type (%{$self->{types}}) {
# add negative match types
$self->{types}->{'no' . $type} = $self->{types}->{$type};
}
bless $self, $class;
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 {
my ($this) = @_;
$this->{debug} = 1;
shift->{debug} = 1;
}
sub errors {
my $self = shift;
return $self->{errors};
}
sub errstr {
my ($this) = @_;
if (exists $this->{error}) {
return $this->{error};
my $self = shift;
return $self->{errors} ? $self->{errors}->[0] : '';
}
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 {
my($this, $config) = @_;
my ($self, $config) = @_;
eval {
$this->traverse($this->{structure}, $config);
};
if ($@) {
$this->{error} = $@;
return FALSE;
}
else {
return TRUE;
}
$self->_traverse($self->{structure}, $config, ());
# return TRUE if no errors
return scalar @{ $self->{errors} } == 0;
}
# Private methods
sub _debug {
my ($this, $msg) = @_;
if ($this->{debug}) {
my ($self, $msg) = @_;
if ($self->{debug}) {
print STDERR "D::V::S::debug() - $msg\n";
}
}
sub traverse {
my($this, $reference, $hash) = @_;
sub _traverse {
my ($self, $reference, $hash, @tree) = @_;
foreach my $key (keys %{$reference}) {
if (ref($reference->{$key}) eq 'ARRAY') {
# just use the 1st one, more elements in array are expected to be the same
foreach my $item (@{$hash->{$key}}) {
if (ref($item) eq q(HASH)) {
$this->traverse($reference->{$key}->[0], $item);
}
else {
# a value, this is tricky
$this->traverse({item => $reference->{$key}->[0]}, { item => $item});
}
if (ref($item) eq q(HASH)) {
# traverse the structure pushing our key to the @tree
$self->_traverse($reference->{$key}->[0], $item, @tree, $key);
}
else {
# a value, this is tricky
$self->_traverse(
{ item => $reference->{$key}->[0] },
{ item => $item },
@tree, $key
);
}
}
}
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 '') {
my @types = _trim( (split /\|/, $reference->{$key}) );
# check data types
if (grep { ! exists $this->{types}->{$_} } @types) {
croak qq(Invalid data type in "$reference->{$key}");
$self->_debug("Checking $key at " . join(', ', @tree));
if (my $err = $self->_check_type($key, $reference, $hash)) {
push @{$self->{errors}}, sprintf(q{%s at '%s'}, $err, join(' => ', @tree));
}
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 {
my($this, $types, $name, $value) = @_;
sub _check_type {
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
my $match = 0;
foreach my $type (@$types) {
foreach my $type (@types) {
# skip optional data type (can't be compared)
next if $type eq 'optional';
# if the type begins with 'no' AND the remainder of the type
# 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
# called 'nothing'.
my $expects = TRUE;
my $expects = 1;
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)
? &{$this->{types}->{$type}}($value) ? TRUE : FALSE # execute closure
: $value =~ /$this->{types}->{$type}/ ? TRUE : FALSE;
# "Evaluate" this $type. We set $result explicitly to 1 or 0
# instead of relying the coderef returning a proper value.
# 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(
"%s = %s, value %s %s", $name, $value, $result ? 'is' : 'is not', $type
$self->_debug(sprintf(
'%s = %s, value %s %s',
$key,
encode('UTF-8', $value),
$result ? 'is' : 'is not',
$type
));
$match ||= ($expects == $result);
}
# die if it doesn't match
die("$name = $value, value doesn't match " . join(' | ', @$types)) unless $match;
return if $match;
# else return gracefully
return;
return sprintf q{'%s' doesn't match '%s'},
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:
qr/[0-9]+/
qr([^%]*)
qr{\w+(\d+?)}
qr/[0-9]+/
qr([^%]*)
qr{\w+(\d+?)}
Please note, that this doesn't mean you can provide
here a regex against config options must match.
@@ -341,9 +364,9 @@ Instead this means that the config options contains a regex.
eg:
<cfg>
grp = qr/root|wheel/
</cfg>
$cfg = {
grp = qr/root|wheel/
};
B<regex> would match the content of the variable 'grp'
in this example.
@@ -363,11 +386,11 @@ Match an IPv4 address.
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:
10.10/16
10.10/16
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
@@ -377,24 +400,24 @@ in L<Regex::Common>.
Match an IPv6 address. Some examples:
3ffe:1900:4545:3:200:f8ff:fe21:67cf
fe80:0:0:0:200:f8ff:fe21:67cf
fe80::200:f8ff:fe21:67cf
ff02:0:0:0:0:0:0:1
ff02::1
3ffe:1900:4545:3:200:f8ff:fe21:67cf
fe80:0:0:0:200:f8ff:fe21:67cf
fe80::200:f8ff:fe21:67cf
ff02:0:0:0:0:0:0:1
ff02::1
=item B<cidrv6>
The same as above including cidr netmask (/64), IPv6 only, eg:
2001:db8:dead:beef::1/64
2001:db8::/32
2001:db8:dead:beef::1/64
2001:db8::/32
=item B<quoted>
Match a text quoted with single quotes, eg:
'barbara is sexy'
'barbara is sexy'
=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.
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!
@@ -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)
eg:
$user is $attribute
I am $(years) old
Missing ${points} points to succeed
$user is $attribute
I am $(years) old
Missing ${points} points to succeed
=back
@@ -496,19 +519,19 @@ hash.
Example:
$reference = { user => 'word', uid => 'int' };
$reference = { user => 'word', uid => 'int' };
The following config would be validated successful:
$config = { user => 'HansDampf', uid => 92 };
$config = { user => 'HansDampf', uid => 92 };
this one not:
$config = { user => 'Hans Dampf', uid => 'nine' };
^ ^^^^
| |
| +----- is not a number
+---------------------- space not allowed
$config = { user => 'Hans Dampf', uid => 'nine' };
^ ^^^^
| |
| +----- is not a number
+---------------------- space not allowed
For easier writing of references you yould use a configuration
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:
$ref = {
'b1' => {
$ref = {
'b1' => {
'b2' => {
'b3' => {
'item' => 'int'
}
}
'b3' => {
'item' => 'int'
}
}
}
}
}
Now if you validate it against the following config hash it
will return TRUE:
$cfg = {
'b1' => {
'b2' => {
'b3' => {
'item' => '100'
}
}
}
}
$cfg = {
'b1' => {
'b2' => {
'b3' => {
'item' => '100'
}
}
}
}
If you validate it for example against this hash, it will
return FALSE:
$cfg = {
'b1' => {
'b2' => {
'item' => '100'
}
}
}
$cfg = {
'b1' => {
'b2' => {
'item' => '100'
}
}
}
=head1 SUBROUTINES/METHODS
@@ -580,22 +603,15 @@ method. Values in this hash can be regexes or anonymous subs.
Example:
$v3->type(
(
address => qr(^\w+\s\s*\d+$),
list =>
sub {
my $list = $_[0];
$v3->type(
address => qr(^\w+\s\s*\d+$),
list => sub {
my $list = shift;
my @list = split /\s*,\s*/, $list;
if (scalar @list > 1) {
return 1;
}
else {
return 0;
}
}
)
);
return scalar @list > 1;
},
);
In this example we add 2 new types, 'list' and 'address', which
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
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()>
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()>
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
@@ -649,7 +675,7 @@ L<Data::Validate::IP> common data validation methods for IP-addresses.
=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
modify it under the same terms as Perl itself.
@@ -710,15 +736,17 @@ or something like this.
=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.
=head1 VERSION
0.07
0.08
=cut

348
t/run.t
View File

@@ -1,5 +1,7 @@
# -*-perl-*-
use utf8;
use Test::More;
use Encode qw{ encode };
require_ok( 'Data::Validate::Struct' );
@@ -43,11 +45,17 @@ my $ref = {
'o1' => 'int | optional',
'AoA' => [ [ 'int' ] ],
'AoH' => [
{ 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 = {
@@ -93,120 +101,217 @@ my $cfg = {
'v27' => '10',
'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' => [
[ qw{ 10 11 12 13 } ],
[ qw{ 20 21 22 23 } ],
[ 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 ]);
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
my @failure =
(
{ cfg => q(acht),
type => q(int)
},
{ 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)
my @failure = (
{
cfg => q(acht),
type => q(int),
descr => 'int',
errors => 1,
},
{
cfg => [
{ fullname => 'Homer Simpson', user => 'homer', uid => 100 },
{ fullname => 'Bart Simpson', user => 'bart', uid => 101 },
{ fullname => 'Lisa Simpson', user => 'lisa:', uid => 102 },
],
cfg => q(27^8),
type => q(number),
descr => 'number',
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 => [
[ qw{ 10 11 12 13 } ],
[ qw{ 20 21 22 23 } ],
[ qw{ 'twenty' 21 22 23 } ],
[ qw{ 30 31 32.0 33 } ],
],
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 $cfg = { v => $test->{cfg} };
my $v = new Data::Validate::Struct($ref);
if ($v->validate($cfg)) {
fail("could not catch invalid '$test->{type}'");
#$v->debug();
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 {
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
my $ref3 = {
my $ref3 = {
v1 => 'address',
v2 => 'list',
v3 => 'noob',
v4 => 'nonoob',
};
my $cfg3 = {
my $cfg3 = {
v1 => 'Marblestreet 15',
v2 => 'a1, b2, b3',
v3 => 42,
v4 => 43,
};
my $v3 = new Data::Validate::Struct($ref3);
$v3->type(
(
address => qr(^\w+\s\s*\d+$),
list =>
sub {
my $list = $_[0];
my @list = split /\s*,\s*/, $list;
if (scalar @list > 1) {
return 1;
}
else {
return 0;
}
},
noob => sub { return $_[0] == 42 },
)
my $v3 = new Data::Validate::Struct($ref3);
# add via hash
note('added via hash');
my %h = (
address => qr(^\w+\s\s*\d+$)
);
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();