—

              
package Data::DynamicValidator;
#ABSTRACT: JPointer-like and Perl union for flexible perl data structures validation
$Data::DynamicValidator::VERSION = '0.05';
use strict;
use warnings;
use Carp;
use Devel::LexAlias qw(lexalias);
use PadWalker qw(peek_sub);
use Scalar::Util qw/looks_like_number/;
use Storable qw(dclone);
use aliased qw/Data::DynamicValidator::Error/;
use aliased qw/Data::DynamicValidator::Filter/;
use aliased qw/Data::DynamicValidator::Label/;
use aliased qw/Data::DynamicValidator::Path/;
use overload
    fallback => 1,
    '&{}' => sub {
        my $self = shift;
        return sub { $self->validate(@_) }
    };
use parent qw/Exporter/;
our @EXPORT_OK = qw/validator/;
use constant DEBUG => $ENV{DATA_DYNAMICVALIDATOR_DEBUG} || 0;
sub validator {
    return Data::DynamicValidator->new(@_);
}
sub new {
    my ($class, $data) = @_;
    my $self = {
        _data   => $data,
        _errors => [],
        _bases  => [],
    };
    return bless $self => $class;
}
sub validate {
    my ($self, %args) = @_;
    my $on      = $args{on     };
    my $should  = $args{should };
    my $because = $args{because};
    my $each    = $args{each   };
    croak("Wrong arguments: 'on', 'should', 'because' should be specified")
        if(!$on || !$should || !$because);
    warn "-- validating : $on \n" if DEBUG;
    my $errors = $self->{_errors};
    my $selection_results;
    if ( !@$errors ) {
        my $success;
        my $current_base = $self->current_base;
        my $selector = $self->_rebase_selector($on);
        ($success, $selection_results) = $self->_apply($selector, $should);
        if (!$success) {
            # if we met an error, and there is only 1 error path
            # we report with expanded path, istead of unexpanded
            my $error_routes = $selection_results->{routes};
            my $reported_error_path = $error_routes && @$error_routes == 1
                ? $error_routes->[0]
                : $selector;
            $self->report_error($because, $reported_error_path);
        }
    }
    # OK, now going to child rules if there is no errors
    if ( !@$errors && $each  ) {
        warn "-- no errors, will check children\n" if DEBUG;
        $self->_validate_children($selection_results, $each);
    }
    return $self;
}
sub report_error {
    my ($self, $reason, $path) = @_;
    $path //= $self->{_current_path};
    croak "Can't report error unless path is undefined"
        unless defined $path;
    push @{ $self->{_errors} }, Error->new($reason, $path);
}
sub is_valid { @{ $_[0]->{_errors} } == 0; }
sub errors { $_[0]->{_errors} }
sub rebase {
    my ($self, $expandable_route, $rule) = @_;
    my $current_base = $self->current_base;
    my $selector = $self->_rebase_selector($expandable_route);
    my $scenario = $self->_select($selector);
    my $number_of_routes = @{ $scenario->{routes} };
    carp "The route '$expandable_route' is ambigious for rebasing (should be unique)"
        if $number_of_routes > 1;
    return $self if $number_of_routes == 0;
    push @{ $self->{_bases} }, $scenario->{routes}->[0];
    $rule->($self);
    pop @{ $self->{_bases} };
    return $self;
}
sub current_base {
    my $bases = $_[0]->{_bases};
    return undef unless @$bases;
    return $bases->[-1];
}
### private/implementation methods
sub _rebase_selector {
    my ($self, $selector) = @_;
    my $current_base = $self->current_base;
    my $add_base = $current_base && $selector !~ /^\/{2,}/;
    my $rebased = $add_base ? $current_base . $selector : $selector;
    warn "-- Rebasing selector $selector to $rebased \n" if DEBUG;
    return $rebased;
}
sub _validate_children {
    my ($self, $selection_results, $each) = @_;
    my ($routes, $values) = @{$selection_results}{qw/routes values/};
    my $errors = $self->{_errors};
    my $data = $self->{_data};
    for my $i (0 .. @$routes-1) {
        my $route = $routes->[$i];
        push @{ $self->{_bases} }, $route;
        my $value = $values->[$i];
        my $label_for = { map { $_ => 1 } ($route->labels) };
        # prepare context
        my $pad = peek_sub($each);
        while (my ($var, $ref) = each %$pad) {
            my $var_name = substr($var, 1); # chomp sigil
            next unless exists $label_for->{$var_name};
            my $label_obj = Label->new($var_name, $route, $data);
            lexalias($each, $var, \$label_obj);
        }
        # call
        $self->{_current_path} = $route;
        $each->($self, local $_ = Label->new('_', $route, $data));
        pop @{ $self->{_bases} };
        last if(@$errors);
    }
}
# Takes path-like expandable expression and returns hashref of path with corresponding
# values from data, e.g.
#  validator({ a => [5,'z']})->_select('/a/*');
#  # will return
#  # {
#  #   routes => ['/a/0', '/a/1'],
#  #   values => [5, z],
#  # }
# Actualy routes are presented by Path objects.
sub _select {
    my ($self, $expession) = @_;
    my $data = $self->{_data};
    my $routes = $self->_expand_routes($expession);
    my $values = [ map { $_->value($data) } @$routes ];
    return {
        routes => $routes,
        values => $values,
    };
}
# Takes xpath-like expandable expression and sorted array of exapnded path e.g.
#  validator({ a => [5,'z']})->_expand_routes('/a/*');
#  # will return [ '/a/0', '/a/1' ]
#  validator({ a => [5,'z']})->_expand_routes('/a');
#  # will return [ '/a' ]
#  validator({ a => { b => [5,'z'], c => ['y']} })->_expand_routes('/a/*/*');
#  # will return [ '/a/b/0', '/a/b/1', '/a/c/0' ]
sub _expand_routes {
    my ($self, $expression) = @_;
    warn "-- Expanding routes for $expression\n" if DEBUG;
    # striping leading slashes
    $expression =~ s/\/{2,}/\//;
    my @routes = ( Path->new($expression) );
    my $result = [];
    while (@routes) {
        my $route = shift(@routes);
        my $current = $self->{_data};
        my $elements = $route->components;
        my $i;
        my $can_be_accessed = 0;
        for ($i = 0; $i < @$elements; $i++) {
            $can_be_accessed = 0;
            my $element = $elements->[$i];
            # no futher examination if current value is undefined
            last unless defined($current);
            next if($element eq '');
            my $filter;
            ($element, $filter) = _filter($element);
            my $type = ref($current);
            my $generator;
            my $advancer;
            if ($element eq '*') {
                if ($type eq 'HASH') {
                    my @keys = keys %$current;
                    my $idx = 0;
                    $generator = sub {
                        while($idx < @keys) {
                            my $key = $keys[$idx++];
                            my $match = $filter->($current->{$key}, {key => $key});
                            return $key if($match);
                        }
                        return undef;
                    };
                } elsif ($type eq 'ARRAY') {
                    my $idx = 0;
                    $generator = sub {
                        while($idx < @$current) {
                            my $index = $idx++;
                            my $match = $filter->($current->[$index], {index => $index});
                            return $index if($match);
                        }
                        return undef;
                    };
                }
            }elsif ($type eq 'HASH' && exists $current->{$element}) {
                $advancer = sub { $current->{$element} };
            }elsif ($type eq 'ARRAY' && looks_like_number($element)
                && (
                    ($element >= 0 && $element < @$current)
                    || ($element < 0 && abs($element) <= @$current)
                   )
                ){
                $advancer = sub { $current->[$element] };
            }
            if ($generator) {
                while ( defined( my $new_element = $generator->()) ) {
                    my $new_path = dclone($route);
                    $new_path->components->[$i] = $new_element;
                    push @routes, $new_path;
                }
                $current = undef;
                last;
            }
            if ($advancer) {
                $current = $advancer->();
                $can_be_accessed = 1;
                next;
            }
            # the current element isn't hash nor array
            # we can't traverse further, because there is more
            # else current path
            $current = undef;
            $can_be_accessed = 0;
        }
        my $do_expansion = defined $current
            || ($can_be_accessed && $i == @$elements);
        warn "-- Expanded route : $route \n" if(DEBUG && $do_expansion);
        push @$result, $route if($do_expansion);
    }
    return [ sort @$result ];
}
sub _filter {
    my $element = shift;
    my $filter;
    my $condition_re = qr/(.+?)(\[(.+)\])/;
    my @parts = $element =~ /$condition_re/;
    if (@parts == 3 && defined($parts[2])) {
        $element = $parts[0];
        my $condition = $parts[2];
        $filter = Filter->new($condition);
    } else {
        $filter = sub { 1 }; # always true
    }
    return ($element, $filter);
}
# Takes the expandable expression and validation closure, then
# expands it, and applies the closure for every data piese,
# obtainted from expansion.
# Returns the list of success validation mark and the hash
# of details (obtained via _select).
sub _apply {
    my ($self, $on, $should) = @_;
    my $selection_results = $self->_select($on);
    my $values = $selection_results->{values};
    my $result = $values && @$values && $should->( @$values );
    return ($result, $selection_results);
};
1;
__END__
HideShow 361 lines of Pod
=pod
=encoding UTF-8
=head1 NAME
Data::DynamicValidator - JPointer-like and Perl union for flexible perl data structures validation
=head1 VERSION
version 0.05
=head1 SYNOPSIS
 my $my_complex_config = {
    features => [
        "a/f",
        "application/feature1",
        "application/feature2",
    ],
    service_points => {
        localhost => {
            "a/f" => { job_slots => 3, },
            "application/feature1" => { job_slots => 5 },
            "application/feature2" => { job_slots => 5 },
        },
        "127.0.0.1" => {
            "application/feature2" => { job_slots => 5 },
        },
    },
    mojolicious => {
        hypnotoad => {
            pid_file => '/tmp/hypnotoad-ng.pid',
            listen  => [ 'http://localhost:3000' ],
        },
    },
 };
 use Data::DynamicValidator qw/validator/;
 use Net::hostent;
 my $errors = validator($cfg)->(
   on      => '/features/*',
   should  => sub { @_ > 0 },
   because => "at least one feature should be defined",
   each    => sub {
     my $f = $_->();
     shift->(
       on      => "//service_points/*/`$f`/job_slots",
       should  => sub { defined($_[0]) && $_[0] > 0 },
       because => "at least 1 service point should be defined for feature '$f'",
     )
   }
 )->(
   on      => '/service_points/sp:*',
   should  => sub { @_ > 0 },
   because => "at least one service point should be defined",
   each    => sub {
     my $sp;
     shift->report_error("SP '$sp' isn't resolvable")
       unless gethost($sp);
   }
 )->(
  on      => '/service_points/sp:*/f:*',
  should  => sub { @_ > 0 },
  because => "at least one feature under service point should be defined",
  each    => sub {
    my ($sp, $f);
    shift->(
      on      => "//features/`*[value eq '$f']`",
      should  => sub { 1 },
      because => "Feature '$f' of service point '$sp' should be decrlared in top-level features list",
    )
  },
  })->rebase('/mojolicious/hypnotoad' => sub {
    shift->(
      on      => '/pid_file',
      should  => sub { @_ == 1 },
      because => "hypnotoad pid_file should be defined",
    )->(
      on      => '/listen/*',
      should  => sub { @_ > 0 },
      because => "hypnotoad listening interfaces defined",
    );
  })->errors;
 print "all OK\n"
  unless(@$errors);
=head2 RATIONALE
There are complex data configurations, e.g. application configs. Not to
check them on applicaiton startup is B<wrong>, because of sudden
unexpected runtime errors can occur, which are not-so-pleasent to detect.
Write the code, that does full exhaustive checks, is B<boring>.
This module tries to offer to use DLS, that makes data validation fun
for developer yet understandable for the person, which provides the data.
=head1 DESCRIPTION
First of all, you should create Validator instance:
 use Data::DynamicValidator qw/validator/;
 my $data = { ports => [2222] };
 my $v = validator($data);
Then, actually do validation:
 $v->(
   on      => '/ports/*',
   should  => sub { @_ > 0 },
   because => 'At least one port should be defined at "ports" section',
 );
The C<on> parameter defines the data path, via JSON-pointer like expression;
the C<should> parameter provides the closure, which will check the values
gathered on via pointer. If the closure returns false, then the error will
be recorded, with description, provided by C<because> parameter.
To get the results of validation, you can call:
 $v->is_valid; # returns true, if there is no validation errors
 $v->errors;   # returns array reference, consisting of the met Errors
C<on>/C<should> parameters are convenient for validation of presense of
something, but they aren't so handy in checking of B<individual> values.
It should be mentioned, that C<should> closure, always takes an array of
the selected by C<on>, even if only one element has been selected.
To handle B<individual> values in more convenient way  the optional
C<each> parameter has been introduced.
 my $data = { ports => [2222, 3333] };
 $v->(
   on      => '/ports/*',
   should  => sub { @_ > 0 },
   because => 'At least one port should be defined at "ports" section',
   each    => sub {
     my $port = $_->();
     $v->report_error("All ports should be greater than 1000")
      unless $port > 1000;
   },
 );
So, C<report_error> could be used for custom errors reporting on current
path or current data value. The C<$_> is the an implicit alias or B<label>
to the last componenet of the current path, i.e. on our case the current
path in C<each> closure will be C</ports/0> and C</ports/1>, so the C<$_>
will be 0 and 1 respectively. To get the I<value> of the label, you should
"invoke" it, as showed previously. A label stringizes to the last data
path component, e.g. to "0" and "1" respectively.
The C<each> closure single argrument is the validator instance itself. The
previous example could be rewriten with explicit label like:
 $v->(
   on      => '/ports/port:*',
   should  => sub { @_ > 0 },
   because => 'At least one port should be defined at "ports" section',
   each    => sub {
     my $port;
     my $port_value = $port->();
     shift->report_error("All ports should be greater than 1000")
      unless $port_value > 1000;
   },
 );
Providing aliases for array indices may be not so handy as for keys
of hashes. Please note, that the label C<port> was previously "declated"
in C<on> rule, and only then "injected" into C<$port> variable in
C<each> closure.
Consider the following example:
 my $data = {
  ports => [2000, 3000],
  2000  => 'tcp',
  3000  => 'udp',
 };
Let's validate it. The validation rule sounds as: there is 'ports' section,
where at least one port > 1000 should be declated, and then the same port
should appear at top-level, and it should be either 'tcp' or 'upd' type.
 use List::MoreUtils qw/any/;
 my $errors = validator($data)->(
   on      => '/ports/*[value > 1000 ]',
   should  => sub { @_ > 0 },
   because => 'At least one port > 1000 should be defined in "ports" section',
   each    => sub {
     my $port = $_->();
     shift->(
       on      => "//*[key eq $port]",
       should  => sub { @_ == 1 && any { $_[0] eq $_ } (qw/tcp udp/)  },
       because => "The port $port should be declated at top-level as tcp or udp",
      )
   }
  )->errors;
As you probably noted, the the path expression contains two slashes at C<on> rule
inside C<each> rule. This is required to search data from the root, because
the current element is been set as B<base> before calling C<each>, so all expressions
inside C<each> are relative to the current element (aka base).
You can change the base explicit way via C<rebase> method:
 my $data = {
    mojolicious => {
        hypnotoad => {
            pid_file => '/tmp/hypnotoad-ng.pid',
            listen  => [ 'http://localhost:3000' ],
        },
    },
 };
 $v->rebase('/mojolicious/hypnotoad' => sub {
    shift->(
      on      => '/pid_file',
      should  => sub { @_ == 1 },
      because => "hypnotoad pid_file should be defined",
    )->(
      on      => '/listen/*',
      should  => sub { @_ > 0 },
      because => "hypnotoad listening interfaces defined",
    );
 })->errors;
=head2 DATA PATH EXPRESSIONS
 my $data = [qw/a b c d e/];
 '/2'   # selects the 'c' value in $data array
 '/-1'  # selects the 'e' value in $data array
 $data = { abc => 123 };
 '/abc' # selects the '123' value in hashref under key 'abc'
 $data = {
   mojolicious => {
     hypnotoad => {
       pid_file => '/tmp/hypnotoad-ng.pid',
     }
   }
 };
 '/mojolicious/hypnotoad/pid_file'  # point to pid_file
 '//mojolicious/hypnotoad/pid_file' # point to pid_file (independently of current base)
 # Escaping by back-quotes sample
 $data => { "a/b" => { c => 5 } }
 '/`a/b`/c' # selects 5
 $data = {abc => [qw/a b/]};   # 1
 $data = {abc => { c => 'd'}}; # 2
 $data = {abc => 7};           # 3
 '/abc/*' # selects 'a' and 'b' in 1st case
          # the 'd' in 2nd case
          # the number 7 in 3rd case
 # Filtering capabilities samples:
 '/abc/*[size == 5]'    # filter array/hash by size
 '/abc/*[value eq "z"]' # filter array/hash by value equality
 '/abc/*[index > 5]'    # finter array by index
 '/abc/*[key =~ /def/]' # finter hash by key
=head2 DEBUGGING
You can set the DATA_DYNAMICVALIDATOR_DEBUG environment variable
to get some advanced diagnostics information printed to "STDERR".
 DATA_DYNAMICVALIDATOR_DEBUG=1
=head1 METHODS
=head2 validate
Performs validation based on C<on>, C<should>, C<because> and optional C<each>
parameters. Returns the validator itself (C<$self>), to allow further C<chain>
invocations. The validation will not be performed, if some errors already
have been detected.
It is recommended to use overloaded function call, instead of this method
call. (e.g. C<$validator->(...)> instead of C<$validato->validate(...)> )
=head2 report_error
The method is used for custom errors reporing. It is mainly usable in C<each>
closure.
 validator({ ports => [1000, 2000, 3000] })->(
   on      => '/ports/port:*',
   should  => sub { @_ > 0 },
   because => "At least one listening port should be defined",
   each    => sub {
     my $port;
     my $port_value = $port->();
     shift->report_error("Port value $port_value isn't acceptable, because < 1000")
       if($port_value < 1000);
   }
 );
=head2 is_valid
Checks, whether validator already has errors
=head2 errors
Returns internal array of errors
=head2 rebase
Temporaly sets the new base to the specified route, and invokes the closure
with the validator instance, i.e.
 $v->('/a' => $closure->($v))
If the data can't be found at the specified route, the C<closure> is not
invoked.
=head2 current_base
Returns the current base, which is set only inside C<rebase> call or C<each> closure.
Returns undef is there is no current base.
=head1 FUNCTIONS
=head2 validator
The enter point for DynamicValidator.
 my $errors = validator(...)->(
   on => "...",
   should => sub { ... },
   because => "...",
 )->errors;
=head1 RESOURCES
=over 4
=item * Data::DPath
L<https://metacpan.org/pod/Data::DPath>
=back
=head1 AUTHOR
Ivan Baidakou <dmol@gmx.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2017 by Ivan Baidakou.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut