mirror of
https://codeberg.org/scip/Data-Validate-Struct.git
synced 2025-12-17 20:51:01 +01:00
Compare commits
1 Commits
c4b1344fed
...
github
| Author | SHA1 | Date | |
|---|---|---|---|
| e035e8cbae |
@@ -1,23 +0,0 @@
|
|||||||
matrix:
|
|
||||||
include:
|
|
||||||
# - image: perl:5.22.4-stretch
|
|
||||||
# - image: perl:5.36.0-slim-bullseye
|
|
||||||
# - image: perl:5.38.0-slim-bookworm
|
|
||||||
# - image: perl:5.40.0-slim-bookworm
|
|
||||||
# - image: perl:5.42.0-slim-bookworm
|
|
||||||
- image: perl:5.43.5-slim-bookworm
|
|
||||||
|
|
||||||
steps:
|
|
||||||
test:
|
|
||||||
when:
|
|
||||||
event: [push]
|
|
||||||
image: ${image}
|
|
||||||
commands:
|
|
||||||
- apt-get update -y
|
|
||||||
- apt-get install -y gcc
|
|
||||||
- cpanm -n Regexp::Common
|
|
||||||
- cpanm -n Data::Validate
|
|
||||||
- cpanm -n Data::Validate::IP
|
|
||||||
- perl Makefile.PL
|
|
||||||
- make
|
|
||||||
- make test
|
|
||||||
@@ -1,54 +0,0 @@
|
|||||||
#!/bin/bash
|
|
||||||
|
|
||||||
# This is my own simple codeberg generic releaser. It takes to
|
|
||||||
# binaries to be uploaded as arguments and takes every other args from
|
|
||||||
# env. Works on tags or normal commits (push), tags must start with v.
|
|
||||||
|
|
||||||
|
|
||||||
set -e
|
|
||||||
|
|
||||||
die() {
|
|
||||||
echo $*
|
|
||||||
exit 1
|
|
||||||
}
|
|
||||||
|
|
||||||
if test -z "$DEPLOY_TOKEN"; then
|
|
||||||
die "token DEPLOY_TOKEN not set"
|
|
||||||
fi
|
|
||||||
|
|
||||||
git fetch --all
|
|
||||||
|
|
||||||
# determine current tag or commit hash
|
|
||||||
version="$CI_COMMIT_TAG"
|
|
||||||
previous=""
|
|
||||||
log=""
|
|
||||||
if test -z "$version"; then
|
|
||||||
version="${CI_COMMIT_SHA:0:6}"
|
|
||||||
log=$(git log -1 --oneline)
|
|
||||||
else
|
|
||||||
previous=$(git tag -l | grep -E "^v" | tac | grep -A1 "$version" | tail -1)
|
|
||||||
log=$(git log -1 --oneline "${previous}..${version}" | sed 's|^|- |g')
|
|
||||||
fi
|
|
||||||
|
|
||||||
# release body
|
|
||||||
printf "# Changes\n\n %s\n" "$log" > body.txt
|
|
||||||
|
|
||||||
# create the release
|
|
||||||
https --ignore-stdin --check-status -b -A bearer -a "$DEPLOY_TOKEN" POST \
|
|
||||||
"https://codeberg.org/api/v1/repos/${CI_REPO_OWNER}/${CI_REPO_NAME}/releases" \
|
|
||||||
tag_name="$version" name="Release $version" body=@body.txt > release.json
|
|
||||||
|
|
||||||
# we need the id to upload files
|
|
||||||
ID=$(jq -r .id < release.json)
|
|
||||||
|
|
||||||
if test -z "$ID"; then
|
|
||||||
cat release.json
|
|
||||||
die "failed to create release"
|
|
||||||
fi
|
|
||||||
|
|
||||||
# actually upload
|
|
||||||
for file in "$@"; do
|
|
||||||
https --ignore-stdin --check-status -A bearer -a "$DEPLOY_TOKEN" -f POST \
|
|
||||||
"https://codeberg.org/api/v1/repos/${CI_REPO_OWNER}/${CI_REPO_NAME}/releases/$ID/assets" \
|
|
||||||
"name=${file}" "attachment@${file}"
|
|
||||||
done
|
|
||||||
@@ -1,23 +0,0 @@
|
|||||||
# build release
|
|
||||||
|
|
||||||
steps:
|
|
||||||
compile:
|
|
||||||
when:
|
|
||||||
event: [tag]
|
|
||||||
image: perl:5.43.5-slim-bookworm
|
|
||||||
commands:
|
|
||||||
- perl Makefile.PL
|
|
||||||
- make
|
|
||||||
- make dist
|
|
||||||
|
|
||||||
release:
|
|
||||||
image: alpine:latest
|
|
||||||
when:
|
|
||||||
event: [tag]
|
|
||||||
environment:
|
|
||||||
DEPLOY_TOKEN:
|
|
||||||
from_secret: DEPLOY_TOKEN
|
|
||||||
commands:
|
|
||||||
- apk update
|
|
||||||
- apk add --no-cache bash httpie jq git
|
|
||||||
- .woodpecker/release.sh ${CI_REPO_NAME}-$CI_COMMIT_TAG.tar.gz
|
|
||||||
98
Changelog
98
Changelog
@@ -1,98 +0,0 @@
|
|||||||
0.13
|
|
||||||
o rework commit 495fcbc: fix bug#14: do not die when
|
|
||||||
array ref doesn't match reference, only report.
|
|
||||||
|
|
||||||
0.12
|
|
||||||
o revert commit 495fcbc, see #7: breaks backwards
|
|
||||||
compatibility.
|
|
||||||
|
|
||||||
0.11
|
|
||||||
o typos
|
|
||||||
|
|
||||||
o added cpanfile
|
|
||||||
|
|
||||||
o don't die when reference types are different
|
|
||||||
|
|
||||||
0.10
|
|
||||||
o fixed RT#101884
|
|
||||||
- _trim() only removed 1st whitespace
|
|
||||||
- optional checks were ineffective if the value was undef
|
|
||||||
0.09
|
|
||||||
o Added AUTHOR, LICENSE and ABSTRACT fields to Makefile.PL
|
|
||||||
|
|
||||||
o Fixed 'Artistic' typo in Makefile.PL
|
|
||||||
|
|
||||||
o fixed cached errors bug - if a validator object has
|
|
||||||
been used multiple times and if during the first
|
|
||||||
run some errors occurred, subsequent runs would show
|
|
||||||
the same error again and again.
|
|
||||||
|
|
||||||
0.08
|
|
||||||
o applied patches by Per Carlson:
|
|
||||||
- don't die on 1st error, rather collect them and
|
|
||||||
issue a full report
|
|
||||||
- use errors() to retrieve all those collected errors
|
|
||||||
- enhanced unit tests
|
|
||||||
- proper utf8 handling
|
|
||||||
- lots of minor tweaks (typos, ambiguities and such)
|
|
||||||
|
|
||||||
o added support for dynamic arguments to validators,
|
|
||||||
which is used by the new range type, see below.
|
|
||||||
arguments passed to coderefs: val, unparsed args, array
|
|
||||||
of args tokenized by , or -.
|
|
||||||
|
|
||||||
o added new builtin validator type: range(start-end),
|
|
||||||
use it like: { loginport => range(22-23) }.
|
|
||||||
|
|
||||||
o export a class method add_validators() [only if requested],
|
|
||||||
which can be used to add validator types globally.
|
|
||||||
|
|
||||||
0.07
|
|
||||||
o lost [updated 11/2014]
|
|
||||||
|
|
||||||
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 check 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
|
|
||||||
7
MANIFEST
7
MANIFEST
@@ -1,7 +0,0 @@
|
|||||||
MANIFEST
|
|
||||||
Makefile.PL
|
|
||||||
Struct.pm
|
|
||||||
README
|
|
||||||
Changelog
|
|
||||||
META.yml Module meta-data (added by MakeMaker)
|
|
||||||
META.json Module meta-data (added by MakeMaker)
|
|
||||||
49
META.json
49
META.json
@@ -1,49 +0,0 @@
|
|||||||
{
|
|
||||||
"abstract" : "Validate recursive hash structures",
|
|
||||||
"author" : [
|
|
||||||
"Thomas v.Dein <tom@cpan.org>",
|
|
||||||
"Per Carlson <pelle@cpan.org>"
|
|
||||||
],
|
|
||||||
"dynamic_config" : 0,
|
|
||||||
"generated_by" : "ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010",
|
|
||||||
"license" : [
|
|
||||||
"perl_5"
|
|
||||||
],
|
|
||||||
"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",
|
|
||||||
"Data::Validate::IP" : "0",
|
|
||||||
"Regexp::Common" : "0"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
},
|
|
||||||
"release_status" : "stable",
|
|
||||||
"resources" : {
|
|
||||||
"repository" : {
|
|
||||||
"url" : "https://codeberg.org/scip/Data-Validate-Struct"
|
|
||||||
}
|
|
||||||
},
|
|
||||||
"version" : 0.12,
|
|
||||||
}
|
|
||||||
27
META.yml
27
META.yml
@@ -1,27 +0,0 @@
|
|||||||
---
|
|
||||||
abstract: 'Validate recursive hash structures'
|
|
||||||
author:
|
|
||||||
- 'Thomas v.Dein <tom@cpan.org>'
|
|
||||||
- 'Per Carlson <pelle@cpan.org>'
|
|
||||||
build_requires:
|
|
||||||
ExtUtils::MakeMaker: '0'
|
|
||||||
configure_requires:
|
|
||||||
ExtUtils::MakeMaker: '0'
|
|
||||||
dynamic_config: 0
|
|
||||||
generated_by: 'ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010'
|
|
||||||
license: perl
|
|
||||||
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:
|
|
||||||
Data::Validate: '0'
|
|
||||||
Data::Validate::IP: '0'
|
|
||||||
Regexp::Common: '0'
|
|
||||||
resources:
|
|
||||||
repository: https://codeberg.org/scip/Data-Validate-Struct
|
|
||||||
version: 0.12
|
|
||||||
35
Makefile.PL
35
Makefile.PL
@@ -1,35 +0,0 @@
|
|||||||
#
|
|
||||||
# Makefile.PL - build file for Date::Validate::Struct
|
|
||||||
#
|
|
||||||
# Copyright (c) 2007-2016 T. v.Dein <tom |AT| cpan.org>.
|
|
||||||
# All Rights Reserved. Std. disclaimer applies.
|
|
||||||
# Artistic License, same as perl itself. Have fun.
|
|
||||||
#
|
|
||||||
|
|
||||||
use ExtUtils::MakeMaker;
|
|
||||||
|
|
||||||
WriteMakefile(
|
|
||||||
NAME => 'Data::Validate::Struct',
|
|
||||||
VERSION_FROM => 'Struct.pm',
|
|
||||||
ABSTRACT => 'Validate recursive hash structures',
|
|
||||||
LICENSE => 'perl',
|
|
||||||
AUTHOR => [
|
|
||||||
'Thomas v.Dein <tom@cpan.org>',
|
|
||||||
'Per Carlson <pelle@cpan.org>',
|
|
||||||
],
|
|
||||||
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' },
|
|
||||||
'META_MERGE' => {
|
|
||||||
resources => {
|
|
||||||
repository => 'https://codeberg.org/scip/Data-Validate-Struct',
|
|
||||||
},
|
|
||||||
},
|
|
||||||
|
|
||||||
);
|
|
||||||
|
|
||||||
@@ -2,6 +2,9 @@
|
|||||||
|
|
||||||
# Data::Validate::Struct - Validate recursive Hash Structures
|
# Data::Validate::Struct - Validate recursive Hash Structures
|
||||||
|
|
||||||
|
> [!CAUTION]
|
||||||
|
> This software is now being maintained on [Codeberg](https://codeberg.org/scip/Data-Validate-Struct/).
|
||||||
|
|
||||||
# SYNOPSIS
|
# SYNOPSIS
|
||||||
|
|
||||||
use Data::Validate::Struct;
|
use Data::Validate::Struct;
|
||||||
|
|||||||
914
Struct.pm
914
Struct.pm
@@ -1,914 +0,0 @@
|
|||||||
#
|
|
||||||
# Copyright (c) 2007-2016 T. v.Dein <tlinden |AT| cpan.org>.
|
|
||||||
# All Rights Reserved. Std. disclaimer applies.
|
|
||||||
# Artistic 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 Encode qw{ encode };
|
|
||||||
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);
|
|
||||||
|
|
||||||
our $VERSION = 0.13;
|
|
||||||
|
|
||||||
use vars qw(@ISA);
|
|
||||||
|
|
||||||
use vars qw(@ISA @EXPORT @EXPORT_OK %__ValidatorTypes);
|
|
||||||
require Exporter;
|
|
||||||
@ISA = qw(Exporter);
|
|
||||||
@EXPORT = qw(%__ValidatorTypes);
|
|
||||||
@EXPORT_OK = qw(add_validators);
|
|
||||||
|
|
||||||
%__ValidatorTypes = (
|
|
||||||
# primitives
|
|
||||||
int => sub { return defined(is_integer($_[0])); },
|
|
||||||
hex => sub { return defined(is_hex($_[0])); },
|
|
||||||
oct => sub { return defined(is_oct($_[0])); },
|
|
||||||
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/(?<!\\) ( \$\w+ | \$\{[^\}]+\} | \$\([^\)]+\) )/x,
|
|
||||||
|
|
||||||
# closures
|
|
||||||
|
|
||||||
# this one doesn't do a stat() syscall, so keep cool
|
|
||||||
path => 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; } },
|
|
||||||
|
|
||||||
# variable integer range, use: range(N1 - N2)
|
|
||||||
range => sub {
|
|
||||||
if ( defined(is_integer($_[0])) && ($_[0] >= $_[2] && $_[0] <= $_[3]) )
|
|
||||||
{ return 1; } else { return 0; } },
|
|
||||||
|
|
||||||
# just a place holder at make the key exist
|
|
||||||
optional => 1,
|
|
||||||
);
|
|
||||||
|
|
||||||
sub add_validators {
|
|
||||||
# class method, add validators globally, not per object
|
|
||||||
my(%v) = @_;
|
|
||||||
foreach my $type (keys %v) {
|
|
||||||
$__ValidatorTypes{$type} = $v{$type};
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub new {
|
|
||||||
my ($class, $structure) = @_;
|
|
||||||
$class = ref($class) || $class;
|
|
||||||
|
|
||||||
my $self = bless {}, $class;
|
|
||||||
|
|
||||||
$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} = \%__ValidatorTypes;
|
|
||||||
$self->{debug} = 0;
|
|
||||||
$self->{errors} = [];
|
|
||||||
|
|
||||||
foreach my $type (keys %{$self->{types}}) {
|
|
||||||
# add negative match types
|
|
||||||
$self->{types}->{'no' . $type} = $self->{types}->{$type};
|
|
||||||
}
|
|
||||||
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub debug {
|
|
||||||
shift->{debug} = 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub errors {
|
|
||||||
my $self = shift;
|
|
||||||
return $self->{errors};
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub errstr {
|
|
||||||
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 ($self, $config) = @_;
|
|
||||||
|
|
||||||
# reset errors in case it's a repeated run
|
|
||||||
$self->{errors} = [];
|
|
||||||
|
|
||||||
$self->_traverse($self->{structure}, $config, ());
|
|
||||||
# return TRUE if no errors
|
|
||||||
return scalar @{ $self->{errors} } == 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
# Private methods
|
|
||||||
|
|
||||||
sub _debug {
|
|
||||||
my ($self, $msg) = @_;
|
|
||||||
if ($self->{debug}) {
|
|
||||||
print STDERR "D::V::S::debug() - $msg\n";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub _traverse {
|
|
||||||
my ($self, $reference, $hash, @tree) = @_;
|
|
||||||
|
|
||||||
foreach my $key (keys %{$reference}) {
|
|
||||||
if (ref($reference->{$key}) eq 'ARRAY') {
|
|
||||||
|
|
||||||
# either it is undefined (optional values)
|
|
||||||
# or it should be an array, so we can derreference it.
|
|
||||||
if (!defined($hash->{$key}) || ref($hash->{$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)) {
|
|
||||||
# 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
|
|
||||||
);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
push @{$self->{errors}}, "$key is not an array";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
elsif (ref($reference->{$key}) eq 'HASH') {
|
|
||||||
$self->_traverse($reference->{$key}, $hash->{$key}, @tree, $key);
|
|
||||||
}
|
|
||||||
elsif (ref($reference->{$key}) eq '') {
|
|
||||||
$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));
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub _check_type {
|
|
||||||
my ($self, $key, $reference, $hash) = @_;
|
|
||||||
|
|
||||||
my (@types, @tmptypes, @tokens);
|
|
||||||
@types = @tmptypes = _trim( (split /\|/, $reference->{$key}) );
|
|
||||||
# check data types
|
|
||||||
if (grep { ! exists $self->{types}->{$_} } map { s/\(.*//; $_ } @tmptypes) {
|
|
||||||
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};
|
|
||||||
|
|
||||||
# is the value checkable?
|
|
||||||
unless (defined $value) {
|
|
||||||
if (grep { $_ eq 'optional' } @types) {
|
|
||||||
# do nothing
|
|
||||||
$self->_debug("$key is optional");
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
# report error
|
|
||||||
return "value of '$key' is undef";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
# the aggregated match over *all* types
|
|
||||||
my $match = 0;
|
|
||||||
foreach my $type (@types) {
|
|
||||||
# skip optional data type (can't be compared)
|
|
||||||
next if $type eq 'optional';
|
|
||||||
|
|
||||||
# tokenize the type into params, only used by coderefs
|
|
||||||
# passed to coderef: &code($value, $typename, $unparsed_args, $arg1, $arg2 ...)
|
|
||||||
($type, @tokens) = _tokenize($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
|
|
||||||
# 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 = 1;
|
|
||||||
if ($type =~ /^no(.*)/) {
|
|
||||||
$expects = 0 if exists $self->{types}->{$1};
|
|
||||||
}
|
|
||||||
|
|
||||||
# "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, @tokens) ? 1 : 0
|
|
||||||
# else it's an regexp, check if it's a match
|
|
||||||
: $value =~ /$self->{types}->{$type}/ ? 1 : 0;
|
|
||||||
|
|
||||||
$self->_debug(sprintf(
|
|
||||||
'%s = %s, value %s %s',
|
|
||||||
$key,
|
|
||||||
encode('UTF-8', $value),
|
|
||||||
$result ? 'is' : 'is not',
|
|
||||||
$type
|
|
||||||
));
|
|
||||||
$match ||= ($expects == $result);
|
|
||||||
}
|
|
||||||
|
|
||||||
return if $match;
|
|
||||||
|
|
||||||
return sprintf q{'%s' doesn't match '%s'},
|
|
||||||
encode('UTF-8', $value), $reference->{$key};
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub _trim {
|
|
||||||
my @a = @_;
|
|
||||||
foreach (@a) {
|
|
||||||
s/^\s+|\s+$//g;
|
|
||||||
}
|
|
||||||
return wantarray ? @a : $a[0];
|
|
||||||
}
|
|
||||||
|
|
||||||
sub _tokenize {
|
|
||||||
my $type = shift;
|
|
||||||
|
|
||||||
if ($type =~ /(.+?)\((.+?)\)/) {
|
|
||||||
print "func pattern\n";
|
|
||||||
# type matches a function like pattern eg highport(1-1023)
|
|
||||||
my $name = $1;
|
|
||||||
my $args = $2;
|
|
||||||
$args =~ s/\s//g;
|
|
||||||
my @params = split /[\,\-]/, $args;
|
|
||||||
return ($name, $args, @params);
|
|
||||||
}
|
|
||||||
|
|
||||||
# default, just return the name as it is
|
|
||||||
return ($type);
|
|
||||||
}
|
|
||||||
|
|
||||||
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<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 L<XML::Simple> could
|
|
||||||
be validated using this module. You may also use it to validate
|
|
||||||
CGI input, just fetch the input data from CGI, L<map> it to a
|
|
||||||
hash and validate it.
|
|
||||||
|
|
||||||
Data::Validate::Struct uses some of the methods exported by L<Data::Validate>,
|
|
||||||
so you need to install it too.
|
|
||||||
|
|
||||||
|
|
||||||
=head1 PREDEFINED BUILTIN DATA TYPES
|
|
||||||
|
|
||||||
=over
|
|
||||||
|
|
||||||
=item B<int>
|
|
||||||
|
|
||||||
Match a simple integer number.
|
|
||||||
|
|
||||||
=item B<range(a-b)>
|
|
||||||
|
|
||||||
Match a simple integer number in a range between a and b. Eg:
|
|
||||||
|
|
||||||
{ loginport => 'range(22-23)' }
|
|
||||||
|
|
||||||
=item B<hex>
|
|
||||||
|
|
||||||
Match a hex value.
|
|
||||||
|
|
||||||
=item B<oct>
|
|
||||||
|
|
||||||
Match an octagonal value.
|
|
||||||
|
|
||||||
=item B<number>
|
|
||||||
|
|
||||||
Match a decimal number, it may contain , or . and may be signed.
|
|
||||||
|
|
||||||
=item B<word>
|
|
||||||
|
|
||||||
Match a single word, _ and - are tolerated.
|
|
||||||
|
|
||||||
=item B<line>
|
|
||||||
|
|
||||||
Match a line of text - no newlines are allowed.
|
|
||||||
|
|
||||||
=item B<text>
|
|
||||||
|
|
||||||
Match a whole text(blob) including newlines. This expression
|
|
||||||
is very loosy, consider it as an alias to B<any>.
|
|
||||||
|
|
||||||
=item B<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:
|
|
||||||
|
|
||||||
$cfg = {
|
|
||||||
grp = qr/root|wheel/
|
|
||||||
};
|
|
||||||
|
|
||||||
B<regex> would match the content of the variable 'grp'
|
|
||||||
in this example.
|
|
||||||
|
|
||||||
To add your own rules for validation, use the B<type()>
|
|
||||||
method, see below.
|
|
||||||
|
|
||||||
=item B<uri>
|
|
||||||
|
|
||||||
Match an internet URI.
|
|
||||||
|
|
||||||
=item B<ipv4>
|
|
||||||
|
|
||||||
Match an IPv4 address.
|
|
||||||
|
|
||||||
=item B<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 L<Regex::Common>.
|
|
||||||
|
|
||||||
=item B<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
|
|
||||||
|
|
||||||
=item B<cidrv6>
|
|
||||||
|
|
||||||
The same as above including cidr netmask (/64), IPv6 only, eg:
|
|
||||||
|
|
||||||
2001:db8:dead:beef::1/64
|
|
||||||
2001:db8::/32
|
|
||||||
|
|
||||||
=item B<quoted>
|
|
||||||
|
|
||||||
Match a text quoted with single quotes, eg:
|
|
||||||
|
|
||||||
'barbara is sexy'
|
|
||||||
|
|
||||||
=item B<hostname>
|
|
||||||
|
|
||||||
Match a valid hostname, it must qualify to the definitions
|
|
||||||
in RFC 2396.
|
|
||||||
|
|
||||||
=item B<resolvablehost>
|
|
||||||
|
|
||||||
Match a hostname resolvable via dns lookup. Will fail if no
|
|
||||||
dns is available at runtime.
|
|
||||||
|
|
||||||
=item B<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!
|
|
||||||
|
|
||||||
=item B<fileexists>
|
|
||||||
|
|
||||||
Look if value is a file which exists. Does a stat() system call.
|
|
||||||
|
|
||||||
=item B<user>
|
|
||||||
|
|
||||||
Looks if the given value is an existent user. Does a getpwnam() system call.
|
|
||||||
|
|
||||||
=item B<group>
|
|
||||||
|
|
||||||
Looks if the given value is an existent group. Does a getgrnam() system call.
|
|
||||||
|
|
||||||
=item B<port>
|
|
||||||
|
|
||||||
Match a valid tcp/udp port. Must be a digit between 0 and 65535.
|
|
||||||
|
|
||||||
=item B<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
|
|
||||||
|
|
||||||
=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 useful to prevent certain things.
|
|
||||||
|
|
||||||
To achieve this, you just have to prepend one of the below mentioned
|
|
||||||
types with the keyword B<no>.
|
|
||||||
|
|
||||||
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<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.
|
|
||||||
|
|
||||||
=head1 NESTED HASH STRUCTURES
|
|
||||||
|
|
||||||
You can also match against nested structures. B<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 B<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'
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
=head1 SUBROUTINES/METHODS
|
|
||||||
|
|
||||||
=over
|
|
||||||
|
|
||||||
=item B<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 $!.
|
|
||||||
|
|
||||||
=item B<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 B<type()>
|
|
||||||
method. Values in this hash can be regexes or anonymous subs.
|
|
||||||
|
|
||||||
C<type> does accept either a hash (C<%hash>), a hash ref (C<%$hash>) or a
|
|
||||||
list of key/values (C<< key => value >>) as input.
|
|
||||||
|
|
||||||
For details see L<CUSTOM VALIDATORS>.
|
|
||||||
|
|
||||||
=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 occurred.
|
|
||||||
|
|
||||||
=item B<errstr()>
|
|
||||||
|
|
||||||
Returns the last error, which is useful to notify the user
|
|
||||||
about what happened. The format is like in L</errors>.
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
=head1 EXPORTED FUNCTIONS
|
|
||||||
|
|
||||||
=head2 add_validators
|
|
||||||
|
|
||||||
This is a class function which adds types not per object
|
|
||||||
but globally for each instance of Data::Validate::Struct.
|
|
||||||
|
|
||||||
use Data::Validate::Struct qw(add_validators);
|
|
||||||
add_validators( name => .. );
|
|
||||||
my $v = Data::Validate::Struct->new(..);
|
|
||||||
|
|
||||||
Parameters to B<add_validators> are the same as of the
|
|
||||||
B<type> method.
|
|
||||||
|
|
||||||
For details see L<CUSTOM VALIDATORS>.
|
|
||||||
|
|
||||||
=head1 CUSTOM VALIDATORS
|
|
||||||
|
|
||||||
You can add your own validators, which maybe regular expressions
|
|
||||||
or anonymous subs. Validators can be added using the B<type()>
|
|
||||||
method or globally using the B<add_validators()> function.
|
|
||||||
|
|
||||||
=head2 CUSTOM REGEX VALIDATORS
|
|
||||||
|
|
||||||
If you add a validator which is just a regular expressions,
|
|
||||||
it will evaluated as is. This is the most simplest way to
|
|
||||||
customize validation.
|
|
||||||
|
|
||||||
Sample:
|
|
||||||
|
|
||||||
use Data::Validate::Struct qw(add_validators);
|
|
||||||
add_validators(address => qr(^\w+\s\s*\d+$));
|
|
||||||
my $v = Data::Validate::Struct->new({place => 'address'});
|
|
||||||
$v->validate({place => 'Livermore 19'});
|
|
||||||
|
|
||||||
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.
|
|
||||||
|
|
||||||
=head2 CUSTOM VALIDATOR FUNCTIONS
|
|
||||||
|
|
||||||
If the validator is a coderef, it will be executed as a sub.
|
|
||||||
|
|
||||||
Example:
|
|
||||||
|
|
||||||
use Data::Validate::Struct qw(add_validators);
|
|
||||||
add_validators(
|
|
||||||
list => sub {
|
|
||||||
my $list = shift;
|
|
||||||
my @list = split /\s*,\s*/, $list;
|
|
||||||
return scalar @list > 1;
|
|
||||||
},
|
|
||||||
);
|
|
||||||
|
|
||||||
In this example we add a new type 'list', which
|
|
||||||
is really simple. 'list' is a subroutine which gets called
|
|
||||||
during evaluation for each option which you define as type 'list'.
|
|
||||||
|
|
||||||
Such a subroutine must return a true value in order to produce a match.
|
|
||||||
It receives the following arguments:
|
|
||||||
|
|
||||||
=over
|
|
||||||
|
|
||||||
=item *
|
|
||||||
|
|
||||||
value to be evaluated
|
|
||||||
|
|
||||||
=item *
|
|
||||||
|
|
||||||
unparsed arguments, if defined in the reference
|
|
||||||
|
|
||||||
=item *
|
|
||||||
|
|
||||||
array of parsed arguments, tokenized by , and -
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
That way you may define a type which accepts an arbitrary number
|
|
||||||
of arguments, which makes the type customizable. Sample:
|
|
||||||
|
|
||||||
# new validator
|
|
||||||
$v4 = Data::Validate::Struct->new({ list => nwords(4) });
|
|
||||||
|
|
||||||
# define type 'nwords' with support for 1 argument
|
|
||||||
$v4->type(
|
|
||||||
nwords => sub {
|
|
||||||
my($val, $ignore, $count) = @_;
|
|
||||||
return (scalar(split /\s+/, $val) == $count) ? 1 : 0;
|
|
||||||
},
|
|
||||||
);
|
|
||||||
|
|
||||||
# validate
|
|
||||||
$v4->validate({ list => 'these are four words' });
|
|
||||||
|
|
||||||
|
|
||||||
=head2 CUSTOM VALIDATORS USING A GRAMMAR
|
|
||||||
|
|
||||||
Sometimes you want to be more flexible, in such cases you may
|
|
||||||
use a parser generator to validate input. This is no feature
|
|
||||||
of Data::Validate::Struct, you will just write a custom code
|
|
||||||
ref validator, which then uses the grammar.
|
|
||||||
|
|
||||||
Here's a complete example using L<Parse::RecDescent>:
|
|
||||||
|
|
||||||
use Parse::RecDescent;
|
|
||||||
use Data::Validate::Struct qw(add_validators);
|
|
||||||
|
|
||||||
my $grammar = q{
|
|
||||||
line: expr(s)
|
|
||||||
expr: number operator number
|
|
||||||
number: int | float
|
|
||||||
int: /\d+/
|
|
||||||
float: /\d*\\.\d+/
|
|
||||||
operator: '+' | '-' | '*' | '/'
|
|
||||||
};
|
|
||||||
|
|
||||||
my $parse = Parse::RecDescent->new($grammar);
|
|
||||||
|
|
||||||
add_validators(calc => sub { defined $parse->line($_[0]) ? 1 : 0; });
|
|
||||||
|
|
||||||
my $val = Data::Validate::Struct->new({line => 'calc'});
|
|
||||||
|
|
||||||
if ($val->validate({line => "@ARGV"})) {
|
|
||||||
my $r;
|
|
||||||
eval "\$r = @ARGV";
|
|
||||||
print "$r\n";
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
print "syntax error\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
Now you can use it as follows:
|
|
||||||
|
|
||||||
./mycalc 54 + 100 - .1
|
|
||||||
153.9
|
|
||||||
|
|
||||||
./mycalc 8^2
|
|
||||||
syntax error
|
|
||||||
|
|
||||||
=head2 NEGATED VALIDATOR
|
|
||||||
|
|
||||||
A negative/reverse match is automatically added as well, see
|
|
||||||
L</NEGATIVE MATCHING>.
|
|
||||||
|
|
||||||
=head1 EXAMPLES
|
|
||||||
|
|
||||||
Take a look to F<t/run.t> 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<perlreftut> Perl references short introduction.
|
|
||||||
|
|
||||||
L<perlref> Perl references, the rest of the story.
|
|
||||||
|
|
||||||
L<perldsc> Perl data structures intro.
|
|
||||||
|
|
||||||
L<perllol> Perl data structures: arrays of arrays.
|
|
||||||
|
|
||||||
L<Data::Validate> common data validation methods.
|
|
||||||
|
|
||||||
L<Data::Validate::IP> common data validation methods for IP-addresses.
|
|
||||||
|
|
||||||
=head1 LICENSE AND COPYRIGHT
|
|
||||||
|
|
||||||
Copyright (c) 2007-2015 T. v.Dein
|
|
||||||
|
|
||||||
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<http://rt.cpan.org>.
|
|
||||||
|
|
||||||
=head1 INCOMPATIBILITIES
|
|
||||||
|
|
||||||
None known.
|
|
||||||
|
|
||||||
=head1 DIAGNOSTICS
|
|
||||||
|
|
||||||
To debug Data::Validate::Struct use B<debug()> or the perl debugger, see L<perldebug>.
|
|
||||||
|
|
||||||
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<Data::Validate>,
|
|
||||||
L<Data::Validate:IP>, L<Regexp::Common>, L<File::Spec> and L<File::stat>.
|
|
||||||
|
|
||||||
=head1 AUTHORS
|
|
||||||
|
|
||||||
T. v.Dein <tlinden |AT| cpan.org>
|
|
||||||
|
|
||||||
Per Carlson <pelle |AT| cpan.org>
|
|
||||||
|
|
||||||
Thanks to David Cantrell for his helpful hints.
|
|
||||||
|
|
||||||
=head1 VERSION
|
|
||||||
|
|
||||||
0.11
|
|
||||||
|
|
||||||
=cut
|
|
||||||
|
|
||||||
8
cpanfile
8
cpanfile
@@ -1,8 +0,0 @@
|
|||||||
# -*-perl-*-
|
|
||||||
requires 'Regexp::Common';
|
|
||||||
requires 'Data::Validate', '0.06';
|
|
||||||
requires 'Data::Validate::IP', '0.18';
|
|
||||||
|
|
||||||
on test => sub {
|
|
||||||
requires 'Test::More';
|
|
||||||
};
|
|
||||||
441
t/run.t
441
t/run.t
@@ -1,441 +0,0 @@
|
|||||||
# -*-perl-*-
|
|
||||||
use utf8;
|
|
||||||
use Test::More;
|
|
||||||
use Encode qw{ encode };
|
|
||||||
|
|
||||||
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',
|
|
||||||
|
|
||||||
'AoA' => [ [ 'int' ] ],
|
|
||||||
|
|
||||||
'AoH' => [
|
|
||||||
{
|
|
||||||
fullname => 'text', user => 'word', uid => 'int' }
|
|
||||||
],
|
|
||||||
|
|
||||||
'HoH' => {
|
|
||||||
father => { fullname => 'text', user => 'word' },
|
|
||||||
son => { fullname => 'text', user => 'word' },
|
|
||||||
daughter => { fullname => 'text', user => 'word' },
|
|
||||||
},
|
|
||||||
|
|
||||||
'r1' => 'range(80-90)',
|
|
||||||
};
|
|
||||||
|
|
||||||
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',
|
|
||||||
|
|
||||||
'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' },
|
|
||||||
},
|
|
||||||
|
|
||||||
'r1' => 85,
|
|
||||||
};
|
|
||||||
|
|
||||||
my $v = new_ok('Data::Validate::Struct', [ $ref ]);
|
|
||||||
ok ($v->validate($cfg), "validate a reference against a OK config");
|
|
||||||
|
|
||||||
|
|
||||||
# check failure matching
|
|
||||||
my @failure = (
|
|
||||||
{
|
|
||||||
cfg => q(acht),
|
|
||||||
type => q(int),
|
|
||||||
descr => 'int',
|
|
||||||
errors => 1,
|
|
||||||
},
|
|
||||||
|
|
||||||
{
|
|
||||||
cfg => q(27^8),
|
|
||||||
type => q(number),
|
|
||||||
descr => 'number',
|
|
||||||
errors => 1,
|
|
||||||
},
|
|
||||||
|
|
||||||
{
|
|
||||||
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{ '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,
|
|
||||||
},
|
|
||||||
|
|
||||||
{
|
|
||||||
cfg => 100,
|
|
||||||
type => 'range(200-1000)',
|
|
||||||
descr => 'value outside dynamic range',
|
|
||||||
errors => 1,
|
|
||||||
},
|
|
||||||
|
|
||||||
);
|
|
||||||
|
|
||||||
foreach my $test (@failure) {
|
|
||||||
my $ref = { v => $test->{type} };
|
|
||||||
my $cfg = { v => $test->{cfg} };
|
|
||||||
my $v = Data::Validate::Struct->new($ref);
|
|
||||||
#$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 {
|
|
||||||
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 = {
|
|
||||||
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);
|
|
||||||
# add via hash
|
|
||||||
note('added via hash');
|
|
||||||
my %h = (
|
|
||||||
address => qr(^\w+\s\s*\d+$)
|
|
||||||
);
|
|
||||||
$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");
|
|
||||||
|
|
||||||
|
|
||||||
# check if errors are not cached
|
|
||||||
my $v4 = Data::Validate::Struct->new({age => 'int'});
|
|
||||||
ok(!$v4->validate({age => 'eight'}), "cache check first run, error");
|
|
||||||
ok($v4->validate({age => 8}), "cache check second run, no error");
|
|
||||||
|
|
||||||
# optional array, see:
|
|
||||||
# https://codeberg.org/scip/Data-Validate-Struct/issues/7
|
|
||||||
my $ref5 = {
|
|
||||||
routers => [ {
|
|
||||||
stubs => [ {
|
|
||||||
network => 'ipv4',
|
|
||||||
}, {} ],
|
|
||||||
}, {}, ],
|
|
||||||
};
|
|
||||||
my $test5 = {
|
|
||||||
'routers' => [
|
|
||||||
{
|
|
||||||
'stubs' => [
|
|
||||||
{
|
|
||||||
'network' => '172.31.199.0',
|
|
||||||
}
|
|
||||||
],
|
|
||||||
'router' => '172.31.199.2', # optional, ignored by validate
|
|
||||||
},
|
|
||||||
{ # optional as well
|
|
||||||
'router' => '172.30.5.5',
|
|
||||||
},
|
|
||||||
],
|
|
||||||
};
|
|
||||||
my $v5 = Data::Validate::Struct->new($ref5);
|
|
||||||
ok($v5->validate($test5), "check optional " . $Data::Validate::Struct::VERSION);
|
|
||||||
|
|
||||||
# different references
|
|
||||||
my $v6 = Data::Validate::Struct->new({ foo => [{bar => 'int'}]});
|
|
||||||
ok(!$v6->validate({foo=>{bar=>10}}));
|
|
||||||
|
|
||||||
done_testing();
|
|
||||||
Reference in New Issue
Block a user