view release on metacpan or  search on metacpan

lib/Data/DynamicValidator.pm  view on Meta::CPAN

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 {