From 8f6fec01460f752dc734ae9ed35c6b2c178157a0 Mon Sep 17 00:00:00 2001 From: "git@daemon.de" Date: Wed, 5 Nov 2014 17:58:51 +0100 Subject: [PATCH] first commit --- Changelog | 46 ++++ MANIFEST | 6 + META.yml | 11 + Makefile.PL | 23 ++ README | 383 +++++++++++++++++++++++++++ Struct.pm | 724 ++++++++++++++++++++++++++++++++++++++++++++++++++++ t/run.t | 263 +++++++++++++++++++ 7 files changed, 1456 insertions(+) create mode 100644 Changelog create mode 100644 MANIFEST create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100644 Struct.pm create mode 100644 t/run.t diff --git a/Changelog b/Changelog new file mode 100644 index 0000000..09327b4 --- /dev/null +++ b/Changelog @@ -0,0 +1,46 @@ +0.06 + o fixed t/run.t, it used still the old name, all tests + failed therefore. + + o replaced some of the built-in regexes with methods + of Data::Validate(the real one :-) ). + + o added 2 new types: hex and oct. + + +0.05 + o well, against renamed it to Data::Validate::Struct, + because Data::Validate already exists. + + o removed chack for 'resolvablehost' because some cpantesters + failed to run it. + + +0.04 + o renamed Config::General::Validate to Data::Validate + because this tells much better what it does. + + o started with 0.x version numbering to show the + early stage of the module. + + o added ipv6 type + + o fixed several bugs with existing types. Thanks to + David Cantrell for some very useful hints. + + o added more documentation. + +-------------- + Original Config::General::Validate Changelog: + 1.03 + o oops - forgot to increase version number, therefore CPAN + didn't get it. + + 1.02 + o removed inheritance of Config::General, which is senceless + + 1.01 + o added Regex::Common support + + 1.00 + o initial release diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..f03d4ab --- /dev/null +++ b/MANIFEST @@ -0,0 +1,6 @@ +MANIFEST +Makefile.PL +Struct.pm +README +Changelog +META.yml Module meta-data (added by MakeMaker) diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..4e47dc9 --- /dev/null +++ b/META.yml @@ -0,0 +1,11 @@ +# 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 +requires: + Regexp::Common: + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.17 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..648fa63 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,23 @@ +# +# Makefile.PL - build file for Date::Validate::Struct +# +# Copyright (c) 2007-2013 Thomas Linden . +# All Rights Reserved. Std. disclaimer applies. +# Artificial License, same as perl itself. Have fun. +# + +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Data::Validate::Struct', + VERSION_FROM => 'Struct.pm', + clean => { FILES => '*~ */*~' }, + PREREQ_PM => { + 'Regexp::Common' => 0, + 'Data::Validate' => '0.06', + 'Data::Validate::IP' => '0.18', + }, + dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, + test => { TESTS => 't/*.t' } +); + diff --git a/README b/README new file mode 100644 index 0000000..b2a6d38 --- /dev/null +++ b/README @@ -0,0 +1,383 @@ +NAME + Data::Validate::Struct - Validate recursive Hash Structures + +SYNOPSIS + use Data::Validate::Struct; + my $validator = new Data::Validate::Struct($reference); + if ( $validator->validate($config_hash_reference) ) { + print "valid\n"; + } + else { + print "invalid " . $validator->errstr() . "\n"; + } + +DESCRIPTION + This module validates a config hash reference against a given hash + structure in contrast to Data::Validate in which you have to check each + value separately using certain methods. + + This hash could be the result of a config parser or just any hash + structure. Eg. the hash returned by XML::Simple could be validated using + this module. You may also use it to validate CGI input, just fetch the + input data from CGI, map it to a hash and validate it. + + Data::Validate::Struct uses some of the methods exported by + Data::Validate, so you need to install it too. + +PREDEFINED BUILTIN DATA TYPES + int Match a simple integer number. + + hex Match a hex value. + + oct Match an octagonal value. + + number + Match a decimal number, it may contain , or . and may be signed. + + word + Match a single word, _ and - are tolerated. + + line + Match a line of text - no newlines are allowed. + + text + Match a whole text(blob) including newlines. This expression is very + loosy, consider it as an alias to any. + + regex + Match a perl regex using the operator qr(). Valid examples include: + + 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. + + Instead this means that the config options contains a regex. + + eg: + + + grp = qr/root|wheel/ + + + regex would match the content of the variable 'grp' in this example. + + To add your own rules for validation, use the type() method, see + below. + + uri Match an internet URI. + + ipv4 + Match an IPv4 address. + + cidrv4 + The same as above including cidr netmask (/24), IPv4 only, eg: + + 10.2.123.0/23 + + Note: shortcuts are not supported for the moment, eg: + + 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. + + 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 + + cidrv6 + The same as above including cidr netmask (/64), IPv6 only, eg: + + 2001:db8:dead:beef::1/64 + 2001:db8::/32 + + quoted + Match a text quoted with single quotes, eg: + + 'barbara is sexy' + + hostname + Match a valid hostname, it must qualify to the definitions in RFC + 2396. + + resolvablehost + Match a hostname resolvable via dns lookup. Will fail if no dns is + available at runtime. + + path + 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 + + will return TRUE if running on WIN32, but FALSE on FreeBSD! + + fileexists + Look if value is a file which exists. Does a stat() system call. + + user + Looks if the given value is an existent user. Does a getpwnam() + system call. + + group + Looks if the given value is an existent group. Does a getgrnam() + system call. + + port + Match a valid tcp/udp port. Must be a digit between 0 and 65535. + + vars + Matches a string of text containing variables (perl style variables + though) eg: + + $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. + + { name => 'int | number' } + + There is no limit on the number of types that can be checked for, and + the check is done in the sequence written (first the type 'int', and + then 'number' in the example above). + +OPTIONAL ITEMS + If there is an element which is optional in the hash, you can use the + type 'optional' in the type. The 'optional' type can also be mixed with + ordinary types, like: + + { name => 'text | optional' } + + The type 'optional' can be placed anywhere in the type string. + +NEGATIVE MATCHING + In some rare situations you might require a negative match. So a test + shall return TRUE if a particular value does NOT match the given type. + This might be usefull to prevent certain things. + + To achieve this, you just have to prepend one of the below mentioned + types with the keyword no. + + Example: + + $ref = { path => 'novars' } + + This returns TRUE if the value of the given config hash does NOT contain + ANY variables. + +VALIDATOR STRUCTURE + The expected structure must be a standard perl hash reference. This hash + may look like the config you are validating but instead of real-live + values it contains types that define of what type a given value has to + be. + + In addition the hash may be deeply nested. In this case the validated + config must be nested the same way as the reference hash. + + Example: + + $reference = { user => 'word', uid => 'int' }; + + The following config would be validated successful: + + $config = { user => 'HansDampf', uid => 92 }; + + this one not: + + $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 + using the syntax of such a module, get the hash of it and use this hash + as validation reference. + +NESTED HASH STRUCTURES + You can also match against nested structures. Data::Validate::Struct + iterates into the given config hash the same way as the reference hash + looks like. + + If the config hash doesn't match the reference structure, perl will + throw an error, which Data::Validate::Struct catches and returns FALSE. + + Given the following reference hash: + + $ref = { + 'b1' => { + 'b2' => { + 'b3' => { + 'item' => 'int' + } + } + } + } + + Now if you validate it against the following config hash it will return + TRUE: + + $cfg = { + 'b1' => { + 'b2' => { + 'b3' => { + 'item' => '100' + } + } + } + } + + If you validate it for example against this hash, it will return FALSE: + + $cfg = { + 'b1' => { + 'b2' => { + 'item' => '100' + } + } + } + +SUBROUTINES/METHODS + validate($config) + $config must be a hash reference you'd like to validate. + + It returns a true value if the given structure looks valid. + + If the return value is false (0), then the error message will be + written to the variable $!. + + type(%types) + You can enhance the validator by adding your own rules. Just add one + or more new types using a simple hash using the type() 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]; + my @list = split /\s*,\s*/, $list; + if (scalar @list > 1) { + return 1; + } + else { + return 0; + } + } + ) + ); + + 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 + an integer. 'list' is a subroutine which gets called during + evaluation for each option which you define as type 'list'. + + Such subroutines must return a true value in order to produce a + match. + + A negative/reverse match is automatically added as well, see + 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. + + debug() + Enables debug output which gets printed to STDERR. + + errstr() + Returns the last error, which is useful to notify the user about + what happened. + +EXAMPLES + Take a look to t/run.t for lots of examples. + +CONFIGURATION AND ENVIRONMENT + No environment variables will be used. + +SEE ALSO + I recommend you to read the following documentations, which are supplied + with perl: + + perlreftut Perl references short introduction. + + perlref Perl references, the rest of the story. + + perldsc Perl data structures intro. + + perllol Perl data structures: arrays of arrays. + + Data::Validate common data validation methods. + + Data::Validate::IP common data validation methods for IP-addresses. + +LICENSE AND COPYRIGHT + Copyright (c) 2007-2013 Thomas Linden + + This library is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + +BUGS AND LIMITATIONS + Some implementation details as well as the API may change in the future. + This will no more happen if entering a stable release (starting with + 1.00). + + To submit use http://rt.cpan.org. + +INCOMPATIBILITIES + None known. + +DIAGNOSTICS + To debug Data::Validate::Struct use debug() or the perl debugger, see + perldebug. + + For example to debug the regex matching during processing try this: + + perl -Mre=debug yourscript.pl + +DEPENDENCIES + Data::Validate::Struct depends on the module Data::Validate, + Data::Validate:IP, Regexp::Common, File::Spec and File::stat. + +TODO + * Add support for ranges, in fact Regexp::Common or Data::Validate + already supports this, but Data::Validate::Struct currently doesn't + support parameters for types. + + * Perhaps add code validation too, for example we could have a type + 'perl' which tries to evaluate the given value. On the other side + this may lead to security holes - so I might never do it. + + * Plugin System + + * Possibly add support for grammars. This might be much more powerful + than regular expressions, say: + + { name => 'expr OP expr | expr' } + + or something like this. + +AUTHOR + Thomas Linden + + Thanks to David Cantrell for his helpful hints. + +VERSION + 0.07 + diff --git a/Struct.pm b/Struct.pm new file mode 100644 index 0000000..076960f --- /dev/null +++ b/Struct.pm @@ -0,0 +1,724 @@ +# +# Copyright (c) 2007-2013 Thomas Linden . +# All Rights Reserved. Std. disclaimer applies. +# Artificial License, same as perl itself. Have fun. +# +# namespace +package Data::Validate::Struct; + +use strict; +use warnings; +use English '-no_match_vars'; +use Carp; +use Exporter; + +use Regexp::Common::URI::RFC2396 qw /$host $port/; +use Regexp::Common qw /URI net delimited/; + +use File::Spec::Functions qw/file_name_is_absolute/; +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; + +use vars qw(@ISA); + +sub new { + my( $this, $structure ) = @_; + my $class = ref($this) || $this; + + 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. + $self->{types} = { + # primitives + int => sub { return defined(is_integer($_[0])); }, + hex => sub { return defined(is_hex($_[0])); }, + oct => sub { return defined(is_oct($_[0])); }, + + # FIXME: add is_between argumented types, need more than one argument + + number => sub { return defined(is_numeric($_[0])); }, + word => qr(^[\w_\-]+$), + line => qr/^[^\n]+$/s, + + text => sub { return defined(is_printable($_[0])); }, + + regex => sub { + my $r = ref $_[0]; + return 1 if $r eq 'Regexp'; + if ($r eq '') { + # this is a bit loosy but should match most regular expressions + # using the qr() operator, but it doesn't check if the expression + # is valid. we could do this by compiling it, but this would lead + # to exploitation possiblities to programs using the module. + return $_[0] =~ qr/^qr ( (.).*\1 | \(.*\) | \{.*\} ) $/x; + } + return 0; + }, + + # via imported regexes + uri => qr(^$RE{URI}$), + cidrv4 => sub { + my ($p, $l) = split(/\//, $_[0]); + return defined(is_ipv4($p)) && defined(is_between($l, 0, 32)); + }, + ipv4 => sub { defined(is_ipv4($_[0])) }, + quoted => qr/^$RE{delimited}{ -delim => qr(\') }$/, + hostname => qr(^$host$), + + ipv6 => sub { defined(is_ipv6($_[0])) }, + cidrv6 => sub { + my ($p, $l) = split('/', $_[0]); + return defined(is_ipv6($p)) && defined(is_between($l, 0, 128)); + }, + + # matches perl style scalar variables + # possible matches: $var ${var} $(var) + vars => qr/(? sub { return file_name_is_absolute($_[0]); }, + + # though this one does it - it stat()s if the file exists + fileexists => sub { return stat($_[0]); }, + + # do a dns lookup on given value, this also fails if + # no dns is available - so be careful with this + resolvablehost => sub { return gethostbyname($_[0]); }, + + # looks if the given value is an existing user on the host system + user => sub { return (getpwnam($_[0]))[0]; }, + + # same with group + group => sub { return getgrnam($_[0]); }, + + # int between 0 - 65535 + port => sub { if ( $_[0] =~ /^$port$/ && ($_[0] > 0 && $_[0] < 65535) ) { return 1; } else { return 0; } }, + + # just a place holder at make the key exist + optional => 1, + }; + + $self->{debug} = 0; + + 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; +} + +sub errstr { + my ($this) = @_; + if (exists $this->{error}) { + return $this->{error}; + } +} + +sub validate { + my($this, $config) = @_; + + eval { + $this->traverse($this->{structure}, $config); + }; + if ($@) { + $this->{error} = $@; + return FALSE; + } + else { + return TRUE; + } +} + +sub _debug { + my ($this, $msg) = @_; + if ($this->{debug}) { + print STDERR "D::V::S::debug() - $msg\n"; + } +} + +sub traverse { + my($this, $reference, $hash) = @_; + + 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}); + } + } + } + elsif (ref($reference->{$key}) eq 'HASH') { + $this->traverse($reference->{$key}, $hash->{$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}"); + } + 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) = @_; + + # the aggregated match over *all* types + my $match = 0; + foreach my $type (@$types) { + 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). + # we must check for both, if not we will get a false match on a type + # called 'nothing'. + my $expects = TRUE; + if ($type =~ /^no(.*)/) { + $expects = FALSE if exists $this->{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; + + $this->_debug(sprintf( + "%s = %s, value %s %s", $name, $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; + + # else return gracefully + return; +} + + +sub _trim { + my @a = @_; + foreach (@a) { + s/^\s+|\s+$//; + } + return wantarray ? @a : $a[0]; +} + +1; + + +__END__ + +=pod + +=head1 NAME + +Data::Validate::Struct - Validate recursive Hash Structures + +=head1 SYNOPSIS + + use Data::Validate::Struct; + my $validator = new Data::Validate::Struct($reference); + if ( $validator->validate($config_hash_reference) ) { + print "valid\n"; + } + else { + print "invalid " . $validator->errstr() . "\n"; + } + +=head1 DESCRIPTION + +This module validates a config hash reference against a given hash +structure in contrast to L in which you have to +check each value separately using certain methods. + +This hash could be the result of a config parser or just any +hash structure. Eg. the hash returned by L could +be validated using this module. You may also use it to validate +CGI input, just fetch the input data from CGI, L it to a +hash and validate it. + +Data::Validate::Struct uses some of the methods exported by L, +so you need to install it too. + + +=head1 PREDEFINED BUILTIN DATA TYPES + +=over + +=item B + +Match a simple integer number. + +=item B + +Match a hex value. + +=item B + +Match an octagonal value. + +=item B + +Match a decimal number, it may contain , or . and may be signed. + +=item B + +Match a single word, _ and - are tolerated. + +=item B + +Match a line of text - no newlines are allowed. + +=item B + +Match a whole text(blob) including newlines. This expression +is very loosy, consider it as an alias to B. + +=item B + +Match a perl regex using the operator qr(). Valid examples include: + + 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. + +Instead this means that the config options contains a regex. + +eg: + + + grp = qr/root|wheel/ + + +B would match the content of the variable 'grp' +in this example. + +To add your own rules for validation, use the B +method, see below. + +=item B + +Match an internet URI. + +=item B + +Match an IPv4 address. + +=item B + +The same as above including cidr netmask (/24), IPv4 only, eg: + + 10.2.123.0/23 + +Note: shortcuts are not supported for the moment, eg: + + 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 L. + +=item B + +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 + +=item B + +The same as above including cidr netmask (/64), IPv6 only, eg: + + 2001:db8:dead:beef::1/64 + 2001:db8::/32 + +=item B + +Match a text quoted with single quotes, eg: + + 'barbara is sexy' + +=item B + +Match a valid hostname, it must qualify to the definitions +in RFC 2396. + +=item B + +Match a hostname resolvable via dns lookup. Will fail if no +dns is available at runtime. + +=item B + +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 + +will return TRUE if running on WIN32, but FALSE on FreeBSD! + +=item B + +Look if value is a file which exists. Does a stat() system call. + +=item B + +Looks if the given value is an existent user. Does a getpwnam() system call. + +=item B + +Looks if the given value is an existent group. Does a getgrnam() system call. + +=item B + +Match a valid tcp/udp port. Must be a digit between 0 and 65535. + +=item B + +Matches a string of text containing variables (perl style variables though) +eg: + + $user is $attribute + I am $(years) old + Missing ${points} points to succeed + +=back + + +=head1 MIXED TYPES + +If there is an element which could match more than one type, this +can be matched by using the pipe sign C<|> to separate the types. + + { name => 'int | number' } + +There is no limit on the number of types that can be checked for, and the +check is done in the sequence written (first the type 'int', and then +'number' in the example above). + + +=head1 OPTIONAL ITEMS + +If there is an element which is optional in the hash, you can use +the type 'optional' in the type. The 'optional' type can also be mixed +with ordinary types, like: + + { name => 'text | optional' } + +The type 'optional' can be placed anywhere in the type string. + + +=head1 NEGATIVE MATCHING + +In some rare situations you might require a negative match. So +a test shall return TRUE if a particular value does NOT match the +given type. This might be usefull to prevent certain things. + +To achieve this, you just have to prepend one of the below mentioned +types with the keyword B. + +Example: + + $ref = { path => 'novars' } + +This returns TRUE if the value of the given config hash does NOT +contain ANY variables. + + +=head1 VALIDATOR STRUCTURE + +The expected structure must be a standard perl hash reference. +This hash may look like the config you are validating but +instead of real-live values it contains B that define +of what type a given value has to be. + +In addition the hash may be deeply nested. In this case the +validated config must be nested the same way as the reference +hash. + +Example: + + $reference = { user => 'word', uid => 'int' }; + +The following config would be validated successful: + + $config = { user => 'HansDampf', uid => 92 }; + +this one not: + + $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 using the syntax of such a module, get the hash of it +and use this hash as validation reference. + +=head1 NESTED HASH STRUCTURES + +You can also match against nested structures. B iterates +into the given config hash the same way as the reference hash looks like. + +If the config hash doesn't match the reference structure, perl will +throw an error, which B catches and returns FALSE. + +Given the following reference hash: + + $ref = { + 'b1' => { + 'b2' => { + 'b3' => { + 'item' => 'int' + } + } + } + } + +Now if you validate it against the following config hash it +will return TRUE: + + $cfg = { + 'b1' => { + 'b2' => { + 'b3' => { + 'item' => '100' + } + } + } + } + +If you validate it for example against this hash, it will +return FALSE: + + $cfg = { + 'b1' => { + 'b2' => { + 'item' => '100' + } + } + } + +=head1 SUBROUTINES/METHODS + +=over + +=item B + +$config must be a hash reference you'd like to validate. + +It returns a true value if the given structure looks valid. + +If the return value is false (0), then the error message will +be written to the variable $!. + +=item B + +You can enhance the validator by adding your own rules. Just +add one or more new types using a simple hash using the B +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]; + my @list = split /\s*,\s*/, $list; + if (scalar @list > 1) { + return 1; + } + else { + return 0; + } + } + ) + ); + +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 an integer. 'list' is a subroutine which gets called +during evaluation for each option which you define as type 'list'. + +Such subroutines must return a true value in order to produce a match. + +A negative/reverse match is automatically added as well, see +L. + +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. + +=item B + +Enables debug output which gets printed to STDERR. + +=item B + +Returns the last error, which is useful to notify the user +about what happened. + +=back + +=head1 EXAMPLES + +Take a look to F for lots of examples. + +=head1 CONFIGURATION AND ENVIRONMENT + +No environment variables will be used. + +=head1 SEE ALSO + +I recommend you to read the following documentations, which are supplied with perl: + +L Perl references short introduction. + +L Perl references, the rest of the story. + +L Perl data structures intro. + +L Perl data structures: arrays of arrays. + +L common data validation methods. + +L common data validation methods for IP-addresses. + +=head1 LICENSE AND COPYRIGHT + +Copyright (c) 2007-2013 Thomas Linden + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 BUGS AND LIMITATIONS + +Some implementation details as well as the API may change +in the future. This will no more happen if entering a stable +release (starting with 1.00). + +To submit use L. + +=head1 INCOMPATIBILITIES + +None known. + +=head1 DIAGNOSTICS + +To debug Data::Validate::Struct use B or the perl debugger, see L. + +For example to debug the regex matching during processing try this: + + perl -Mre=debug yourscript.pl + +=head1 DEPENDENCIES + +Data::Validate::Struct depends on the module L, +L, L, L and L. + +=head1 TODO + +=over + +=item * + +Add support for ranges, in fact L or L already +supports this, but B currently doesn't support +parameters for types. + +=item * + +Perhaps add code validation too, for example we could have +a type 'perl' which tries to evaluate the given value. On the +other side this may lead to security holes - so I might never do it. + +=item * + +Plugin System + +=item * + +Possibly add support for grammars. This might be much more powerful +than regular expressions, say: + + { name => 'expr OP expr | expr' } + +or something like this. + +=back + +=head1 AUTHOR + +Thomas Linden + +Thanks to David Cantrell for his helpful hints. + +=head1 VERSION + +0.07 + +=cut + diff --git a/t/run.t b/t/run.t new file mode 100644 index 0000000..9ba88f4 --- /dev/null +++ b/t/run.t @@ -0,0 +1,263 @@ +# -*-perl-*- +use Test::More; + +require_ok( 'Data::Validate::Struct' ); + +my $ref = { + 'b1' => { + 'b2' => { + 'b3' => { + 'item' => 'int' + } + } + }, + 'item' => [ 'number' ], + 'v1' => 'int', + 'v2' => 'number', + 'v3' => 'word', + 'v4' => 'line', + 'v5' => 'text', + 'v6' => 'hostname', + 'v8' => 'user', + 'v10' => 'port', + 'v11' => 'uri', + 'v12' => 'cidrv4', + 'v13' => 'ipv4', + 'v14' => 'path', + 'v15' => 'fileexists', + 'v16' => 'quoted', + 'v171' => 'regex', + 'v172' => 'regex', + 'v18' => 'novars', + 'v19' => 'ipv6', + 'v20' => 'ipv6', + 'v21' => 'ipv6', + 'v22' => 'ipv6', + 'v23' => 'ipv6', + 'v24' => 'ipv6', + 'v25' => 'ipv6', + 'v26' => 'cidrv6', + + 'v27' => 'int | vars', + 'v28' => 'int | vars', + + 'o1' => 'int | optional', + + 'AoH' => [ + { fullname => 'text', user => 'word', uid => 'int' } + ], + + 'AoA' => [ [ 'int' ] ], + }; + +my $cfg = { + 'b1' => { + 'b2' => { + 'b3' => { + 'item' => '100' + } + } + }, + 'item' => [ + '10', + '20', + '30' + ], + 'v1' => '123', + 'v2' => '19.03', + 'v3' => 'Johannes', + 'v4' => 'this is a line of text', + 'v5' => 'This is a text block + This is a text block', + 'v6' => 'search.cpan.org', + 'v8' => 'root', + 'v10' => '22', + 'v11' => 'http://search.cpan.org/~tlinden/?ignore¬=1', + 'v12' => '192.168.1.101/18', + 'v13' => '10.0.0.193', + 'v14' => '/etc/ssh/sshd.conf', + 'v15' => 'MANIFEST', + 'v16' => '\' this is a quoted string \'', + 'v171' => qr([0-9]+), + 'v172' => 'qr([0-9]+)', + 'v18' => 'Doesnt contain any variables', + 'v19' => '3ffe:1900:4545:3:200:f8ff:fe21:67cf', + 'v20' => 'fe80:0:0:0:200:f8ff:fe21:67cf', + 'v21' => 'fe80::200:f8ff:fe21:67cf', + 'v22' => 'ff02:0:0:0:0:0:0:1', + 'v23' => 'ff02::1', + 'v24' => '::ffff:192.0.2.128', + 'v25' => '::', + 'v26' => '2001:db8:dead:beef::b00c/64', + + '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 } ], + ], + + }; + +my $v = new_ok('Data::Validate::Struct', [ $ref ]); +ok ($v->validate($cfg), "validate a reference against a config " . $v->errstr()); + + + +# 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) + }, + + { + 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' } + ], + }, + + { + cfg => [ + [ qw{ 10 11 12 13 } ], + [ qw{ 20 21 22 23 } ], + [ qw{ 30 31 32.0 33 } ], + ], + + type => [ [ 'int' ] ], + }, + +); + +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}'"); + } + else { + pass("catched invalid '$test->{type}'"); + } +} + + + +# adding custom type +my $ref3 = { + v1 => 'address', + v2 => 'list', + v3 => 'noob', + v4 => 'nonoob', +}; +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 }, + ) +); +ok($v3->validate($cfg3), "using custom types " . $v3->errstr()); + +done_testing(); +