diff --git a/Changelog b/Changelog index 09327b4..6c1c7e3 100644 --- a/Changelog +++ b/Changelog @@ -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. diff --git a/META.json b/META.json new file mode 100644 index 0000000..3cc401d --- /dev/null +++ b/META.json @@ -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" +} diff --git a/META.yml b/META.yml index 4e47dc9..ec42445 100644 --- a/META.yml +++ b/META.yml @@ -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 diff --git a/Makefile.PL b/Makefile.PL index 648fa63..52b2a95 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,7 +1,7 @@ # # Makefile.PL - build file for Date::Validate::Struct # -# Copyright (c) 2007-2013 Thomas Linden . +# Copyright (c) 2007-2014 T. v.Dein . # All Rights Reserved. Std. disclaimer applies. # Artificial License, same as perl itself. Have fun. # diff --git a/README b/README index b2a6d38..0a9d5ea 100644 --- a/README +++ b/README @@ -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: - - grp = qr/root|wheel/ - + $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 ' doesn't match at + ', where 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 . INCOMPATIBILITIES None known. @@ -373,11 +375,13 @@ TODO or something like this. -AUTHOR - Thomas Linden +AUTHORS + T. v.Dein + + Per Carlson Thanks to David Cantrell for his helpful hints. VERSION - 0.07 + 0.08 diff --git a/Struct.pm b/Struct.pm index 076960f..c8cad63 100644 --- a/Struct.pm +++ b/Struct.pm @@ -1,5 +1,5 @@ # -# Copyright (c) 2007-2013 Thomas Linden . +# Copyright (c) 2007-2014 T. v.Dein . # 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. 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: - - grp = qr/root|wheel/ - + $cfg = { + grp = qr/root|wheel/ + }; B 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. 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 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 Match a text quoted with single quotes, eg: - 'barbara is sexy' + 'barbara is sexy' =item B @@ -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 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 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 Enables debug output which gets printed to STDERR. +=item B + +Returns an array ref with the errors found when validating the hash. +Each error is on the format ' doesn't match at ', +where is a comma separated tree view depicting where in the +the error occured. + =item B Returns the last error, which is useful to notify the user -about what happened. +about what happened. The format is like in L. =back @@ -649,7 +675,7 @@ L 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 +T. v.Dein + +Per Carlson Thanks to David Cantrell for his helpful hints. =head1 VERSION -0.07 +0.08 =cut diff --git a/t/run.t b/t/run.t index 9ba88f4..c7b1ddd 100644 --- a/t/run.t +++ b/t/run.t @@ -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(< q(line) - }, - - { cfg => q(ätz), - type => q(hostname) - }, - - { cfg => q(gibtsnet123456790.intern), - type => q(resolvablehost) - }, - - { cfg => q(äüö), - type => q(user) - }, - - { cfg => q(äüö), - type => q(group) - }, - - { cfg => q(234234444), - type => q(port) - }, - - { cfg => q(unknown:/unsinnüäö), - type => q(uri) - }, - - { cfg => q(1.1.1.1/33), - type => q(cidrv4) - }, - - { cfg => q(300.1.1.1), - type => q(ipv4) - }, - - { cfg => q(üäö), - 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(< 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();