File Coverage

blib/lib/Data/Transpose/Validator.pm

Criterion	Covered	Total	%
statement	263	265	99.2
branch	108	130	83.0
condition	37	61	60.6
subroutine	34	34	100.0
pod	15	15	100.0
total	457	505	90.5

package Data::Transpose::Validator;

use strict;
use warnings;
use Module::Load;
use Try::Tiny;
# use Data::Dumper;
use Data::Transpose::Validator::Subrefs;
use Data::Transpose::Validator::Group;
use Data::Transpose::Iterator::Errors;

use Moo;
use MooX::Types::MooseLike::Base qw(:all);
use namespace::clean;

=head1 NAME

Data::Transpose::Validator - Filter and validate data.

=head1 SYNOPSIS

  use Data::Transpose::Validator;
  my $dtv = Data::Transpose::Validator->new();
  $dtv->prepare(email => {validator => 'EmailValid',
                          required => 1},
                password => {validator => 'PasswordPolicy',
                             required => 1}
               );

  my $form = {
              email => "aklasdfasdf",
              password => "1234"
             };

  my $clean = $dtv->transpose($form);
  if ($clean) {
      # the validator says it's valid, and the hashref $clean is validated
      # $clean is the validated hash
  } else {
      my $errors = $dtv->errors; # arrayref with the errors
      # old data
      my $invalid_but_filtered = $dtv->transposed_data; # hashref with the data
  }

=head1 DESCRIPTION

This module provides an interface to validate and filter hashrefs,
usually (but not necessarily) from HTML forms.

=head1 METHODS


=head2 new

The constructor. It accepts a hash as argument, with options:

C: strip leading and trailing whitespace from strings (default: true)

C: collapse all the consecutive whitespace
characters into a single space. This basically will do a C
against the value, so will remove all newlines and tabs as well.
Default is false.

C: require all the fields of the schema (default: false)

C: what to do if other fields, not present in the schema, are passed.

=over 4

C: The transposing routine will die with a message stating the unknown fields

C: The routine will accept them and return them in the validated hash

C: The routine will ignore them and not return them in the validated hash. This is the default.

=back

C: what to do if an optional field is missing

=over 4

C: do nothing, don't add to the returning hash the missing keys. This is the default.

C: add the key with the C value

C: set it to the empty string;

=back

=cut

has stripwhite => (is => 'rw',
                   isa => Bool,
                   default => sub { 1 });

has collapse_whitespace => (is => 'rw',
                            isa => Bool,
                            default => sub { 0 });

has requireall => (is => 'rw',
                   isa => Bool,
                   default => sub { 0 });

has unknown => (is => 'rw',
                isa => Enum[qw/skip fail pass/],
                default => sub { 'skip' });

has missing => (is => 'rw',
                isa => Enum[qw/pass undefine empty/],
                default => sub { 'pass' });

has success => (is => 'rwp',
                isa => Maybe[Bool],
               );

has errors_iterator => (is => 'ro',
                        default => sub {
                            Data::Transpose::Iterator::Errors->new;
                        });

has _fields => (is => 'rw',
                isa => HashRef,
                default => sub { {} });

has _ordering => (is => 'rw',
                  isa => ArrayRef,
                  default => sub { [] });

has transposed_data => (is => 'rwp',
                        isa => Maybe[HashRef]);

has groups => (is => 'rwp',
               isa => ArrayRef,
               default => sub { [] });


=head2 option($option, [ $value ]);

Accessor to the options set. With an optional argument, set that option.

  $dtv->option("requireall"); # get
  $dtv->option(requireall => 1); # set

This is another way to say $dtv->requireall(1);

=cut

sub option {
    my ($self, $key, $value) = @_;
    return unless $key;
    my %supported = map { $_ => 1 } $self->options;
    die "Bad option $key, should be one of " . join(" ", $self->options)
      unless $supported{$key};
    if (defined $value) {
        $self->$key($value);
    }
    return $self->$key;
}

=head2 option_for_field($option, $field)

Accessor to get the option for this particular field. First it looks
into the fields options, then into the global ones, returning the
first defined value.

  $dtv->option(email => "stripwhite");

=cut

sub option_for_field {
    my ($self, $option, $field) = @_;
    return unless ($field && $option);
    my $hash = $self->field($field)->dtv_options;
    # print Dumper($hash);
    if ($hash and (ref($hash) eq 'HASH') and exists $hash->{$option}) {
        return $hash->{$option};
    }
    return $self->option($option) # return the global one;
}




=head2 options

Accessor to get the list of the options

  $dtv->options;
  # -> requireall, stripwhite, unknown

=cut

sub options {
    return qw/collapse_whitespace
              missing
              requireall
              stripwhite
              unknown
             /;
}

=head2 prepare(%hash) or prepare([ {}, {}, ... ])

C takes a hash and pass the key/value pairs to C. This
method can accept an hash or an array reference. When an arrayref is
passed, the output of the errors will keep the provided sorting (this
is the only difference).

You can call prepare as many times you want before the transposing.
Fields are added or replaced, but you could end up with messy errors
if you provide duplicates, so please just don't do it (but feel free
to add the fields at different time I
them>.

To prevent bad configuration, as of version 0.0005 overwriting an
existing field raises an exception.

  $dtv->prepare([
                  { name => "country" ,
                    required => 1,
                  },
                  {
                   name => "country2",
                   validator => 'String'},
                  {
                   name => "email",
                   validator => "EmailValid"
                  },
                 ]
                );

or

  $dtv->prepare(
                country => {
                            required => 1,
                           },
                country2 => {
                             validator => "String"
                            }
               );

  ## other code here

  $dtv->prepare(
               email => {
                         validator => "EmailValid"
                        }
               );


The validator value can be an string, a hashref or a coderef.

When a string is passed, the class which will be loaded will be
prefixed by C and initialized without
arguments.

If a coderef is passed as value of validator, a new object
L is created, with the coderef as
validator.

If a hashref is passed as value of validator, it must contains the key
C and optionally C as an hashref. As with the string,
the class will be prefixed by C, unless
you pass the C key set to a true value.


  $dtv->prepare(
          email => {
              validator => "EmailValid",
               },

          # ditto
          email2 => {
               validator => {
                       class => "EmailValid",
                      }
              },

          # tritto
          email3 => {
               validator => {
                       class => "Data::Transpose::Validator::EmailValid",
                       absolute => 1,
                      }
              },

          # something more elaborate
          password => {
                 validator => {
                       class => PasswordPolicy,
                       options => {
                             minlength => 10,
                             maxlength => 50,
                             disabled => {
                                    username => 1,
                                   }
                            }
                      }
              }
         );

=head3 Groups

You can set the groups either calling C (see below) or with
C, using the validator C with C.

Using an arrayref:

  $dtv->prepare([
                 {
                   name => 'password',
                   required => 1,
                  },
                  {
                   name => 'confirm_password',
                   required => 1,
                  },
                  {
                   name => 'passwords',
                   validator => 'Group',
                   fields => [
                              qw/password confirm_password/,
                             ],
                   equal => 1,
                  },
                 ]
                 );

Or using an hash

  $dtv->prepare(password => { required => 1 },
                confirm_password => { required => 1 },
                passwords_matching => {
                                       validator => 'Group',
                                       fields => [ "password", "confirm_password" ]
                                      });

By default, if a group is set, it will be checked if all the fields
match. So using the above schema, you'll get:

  ok $dtv->transpose({ password => "a", confirm_password => "a" });
  ok !$dtv->transpose({ password => "a", confirm_password => "b" });


=head3 Bundled classes

Each class has its own documentation for the available options. The
options are passed to the C constructor of the validator's class.

=over 4

=item CreditCard

See L

Options: C and C

=item EmailValid

See L (no special options)

=item NumericRange

See L

Options: C, C, C

=item PasswordPolicy

See L (plenty of options, refers to
the documentation).

=item Set

See L.

Options: C pointing to an arrayref and the C boolean
(to validate an arrayref).

=item String

See L (no special options).

=item URL

See L (no special options).

=back

=cut

sub prepare {
    my $self = shift;
    # groups should be processed at the end, because, expecially if an
    # hash is passed, they could be processed before the fields are
    # created.
    my @groups;
    if (@_ == 1) {
        # we have an array;
        my $arrayref = shift;
        die qq{Wrong usage! If you pass a single argument, must be a arrayref\n"}
          unless (ref($arrayref) eq 'ARRAY');
        foreach my $field (@$arrayref) {
            # defer the group building
            if (exists $field->{validator} and $field->{validator}) {
                if ($field->{validator} eq 'Group') {
                    push @groups, $field;
                    next;
                }
            }
            my $fieldname = $field->{name};
            die qq{Wrong usage! When an array is passed, "name" must be set!}
              unless $fieldname;
            $self->field($fieldname, $field);
        }
    }
    else {
        my %fields = @_;
        while (my ($k, $v) = each %fields) {
            if (ref($v)
                and ref($v) eq 'HASH'
                and exists $v->{validator}
                and $v->{validator} eq 'Group') {
                my $grp =  { %$v };
                $grp->{name} = $k;
                push @groups, $grp;
                next;
            }
            $self->field($k, $v);
        }
    }
    # fields are fine, build the groups
    # in the configuration we can't have objects
    foreach my $g (@groups) {
        die "Missing group name" unless $g->{name};
        die "Missing fields for $g->{name} group!" unless $g->{fields};
        my @gfields;
        foreach my $f (@{ $g->{fields} }) {
            my $obj = $self->field($f);
            die "Couldn't retrieve field object for group $g->{name}, field $f"
              unless $obj;
            push @gfields, $obj;
        }
        die "No fields found for group $g->{name}" unless @gfields;
        # build the group
        my $group_obj = $self->group($g->{name}, @gfields);
        # and now loops over the other keys and try to call the methods.
        # say ->equal(0)
        my %skip = (
                    name => 1,
                    fields => 1,
                    validator => 1,
                   );
        foreach my $method (keys %$g) {
            next if $skip{$method};
            # e.g $group_obj->equal(1)
            $group_obj->$method($g->{$method});
        }
    }
}

=head2 field($field)

This accessor sets the various fields and their options. It's intended
to be used only internally, but you can add individual fields with it

  $dtv->field(email => { required => 1 });

If the second argument is a string, it is assumed as the validator name. E.g.

  $dtv->field(email => 'EmailValid');

This by itself use the EmailValid with the default settings. If you
want fine control you need to pass an hashref. Also note that unless
you specified C as true in the constructor, you need to
set the require.

So these syntaxes do the same:

    $dtv->field(email => { required => 1,
                           validator => 'EmailValid',
                         });
    $dtv->field(email => 'EmailValid')->required(1);

With 1 argument retrieves the object responsible for the validation of
that field, so you can call methods on them:

  $dtv->field(email => { required => 0 })->required(1);
  $dtv->field('email')->required # return true

You can also pass options for the validator, e.g.:

 $dtv->field('month' => { validator => 'NumericRange',
                          options => {
                              min => 1,
                              max => 12,
                              integer => 1
                          },
                         });

WARNING: Earlier versions of this method without any argument would
have retrieved the whole structure. Now it dies instead.

=cut

sub field {
    my ($self, $field, $args) = @_;
    # initialize
    unless ($field) {
        my $deprecation =<<'DEATH';
As of version 0.0005, the retrieval of the whole structure without
field argument is deprecated, as fields return an object instead!
DEATH
        die $deprecation unless $field;
    }

    if ($args) {
        unless (ref($field) eq '') {
            die "Wrong usage, $field must be a string with the field name!\n"
        };

        # if a string is passed, consider it as a validator
        unless (ref($args)) {
            $args = { validator => $args };
        }
        #  validate the args and store them
        if (ref($args) eq 'HASH') {
            $self->_field_args_are_valid($field => keys %$args);
            my $obj = $self->_build_object($field, $args);
            # prevent to mix up rules.
            if ($self->_fields->{$field}) {
                die "$field has already a validation rule!\n";
            }
            $self->_fields->{$field} = $obj;
        }
        else {
            # raise exception to prevent bad configurations
            die "Argument for $field must be an hashref, got $args!\n";
        }
        # add the field to the list
        $self->_sorted_fields($field);
    }
    return $self->_fields->{$field};
}

sub _sorted_fields {
    my ($self, $field) = @_;
    if ($field) {
        push @{$self->_ordering}, $field;
    }
    return @{$self->_ordering};
}

# return the sorted list of fields

=head2 group (name => $field1, $field2, $field3, ...)

Create a named group of fields and schedule them for validation.

The logic is:

First, the individual fields are normally checked according to the
rules provided with C or C.

If they pass the test, the group operation are checked.

Group by itself returns a L object,
so you can call methods on them to set the rules.

E.g. $self->group("passwords")->equal(1) # not needed it's the default

=head2 groups

Retrieve the list of the group objects scheduled for validation

=cut

sub group {
    my ($self, $name, @objects) = @_;
    die "Wrong usage, first argument must be a string!" unless $name && !ref($name);
    if (@objects) {
        my @group;
        foreach my $field (@objects) {
            my $obj = $field;
            unless (ref($field)) {
                $obj = $self->field($field);
            }
            # if we couldn't retrieve the field, die, we can't build the group
            die "$obj could not be retrieved! Too early for this?" unless $obj;
            push @group, $obj;
        }
        my $group = Data::Transpose::Validator::Group->new(name => $name,
                                                           fields => \@group);

        push @{ $self->groups }, $group;
        # store it in the dtv object and return it
        return $group;
    }
    # retrieve
    foreach my $g (@{ $self->groups }) {
        if ($g->name eq $name) {
            return $g;
        }
    }
    return;
}


=head2 transpose

The main method. It validates the hash and return a validated one or
nothing if there were errors.

=cut




sub transpose {
    my ($self, $hash) = @_;
    die "Wrong usage! A hashref is needed as argument for transpose method!\n"
      unless ($hash and (ref($hash) eq 'HASH'));
    $self->reset_self;


    my (%output, %status);

    # remember which keys we had processed
    $status{$_} = 1 for keys %$hash;

    # we loop over the schema
    foreach my $field ($self->_sorted_fields) {
        my $obj = $self->field($field);
        $obj->reset_dtv_value;
        my $value;
        # the incoming hash could not have such a field
        if (exists $status{$field}) {

            delete $status{$field};
            $value = $hash->{$field};

            # strip white if the option says so
            if ($self->option_for_field('stripwhite', $field)) {
                $value = $self->_strip_white($value);
            }
            if ($self->option_for_field(collapse_whitespace => $field)) {
                $value = $self->_collapse_white($value);
            }
            # then we set it in the ouput, it could be undef;
            $output{$field} = $value;
        }
        else {
            my $missingopt = $self->option_for_field('missing', $field);
            # basically, with "pass", the default, we don't store the
            # value
            if ($missingopt eq 'undefine') {
                $value = undef;
                $output{$field} = $value;
            }
            elsif ($missingopt eq 'empty') {
                $value = "";
                $output{$field} = $value;
            }
        }


        # if it's required and the only thing provided is "" or undef,
        # we set an error
        if ((not defined $value) or
            ((ref($value) eq '') and $value eq '') or
            ((ref($value) eq 'HASH') and (not %$value)) or
            ((ref($value) eq 'ARRAY') and (not @$value))) {

            if ($self->field_is_required($field)) {
                # set the error list to ["required" => "Human readable" ];
                $self->errors($field,
                              [
                               [ "required" => "Missing required field $field" ]
                              ]
                             );
            }
            next;
        }
        # we have something, validate it
        unless ($obj->is_valid($value)) {
            my @errors = $obj->error;
            $self->errors($field, \@errors)
        }
        $obj->dtv_value($value);
    }


    # if there is no error, check the groups
    unless ($self->errors) {
        foreach my $group (@{$self->groups}) {
            unless ($group->is_valid) {
                my @errors = $group->error;
                $self->errors($group->name, \@errors);
            }
        }
    }

    # now the filtering loop has ended. See if we have still things in the hash.
    if (keys %status) {
        my $unknown = $self->option('unknown');
        if ($unknown eq 'pass') {
            for (keys %status) {
                $output{$_} = $hash->{$_};
            }
        } elsif ($unknown eq 'fail') {
            die "Unknown fields in input: ", join(',', keys %status), "\n";
        }
    }
    # remember what we did
    $self->_set_transposed_data(\%output);

    if ($self->errors) {
        # return undef if we have errors
        $self->_set_success(0);
        return;
    }

    # return the data
    $self->_set_success(1);

    return $self->transposed_data;
}

=head2 success

Returns true on success, 0 on failure and undef validation
didn't take place.

=head2 transposed_data

Accessor to the transposed hash. This is handy if you want to retrieve
the filtered data after a failure (because C will return
undef in that case).

=head2 errors

Accessor to set or retrieve the errors (returned as an arrayref of
hashes). Each element has the key C set to the fieldname and
the key C holds the error list. This, in turn, is a list
of arrays, where the first element is the error code, and the second
the human format set by the module (in English). See the method belows
for a more accessible way for the errors.

=cut

sub errors {
    my ($self, $field, $error) = @_;
    if ($error and $field) {
        $self->errors_iterator->append({field => $field,
                                         errors => $error});
    }

    if ($self->errors_iterator->count) {
        return $self->errors_iterator->records;
    }

    return;
}

=head2 errors_iterator

Returns error iterator.

=cut

=head2 errors_hash

Return an hashref where each key is the name of the error field, and
the value is an arrayref of hashrefs with two keys, C and
C.

Example of the returned hash:

          {
           year => [
                    {
                     value => 'Not a number',
                     name => 'notanumber',
                    },
                    {
                     name => 'notinteger',
                     value => 'Not an integer',
                    }
                   ],
           mail => [
                    {
                     value => 'Missing required field mail',
                     name => 'required',
                    }
                   ],
          }

=cut

sub errors_hash {
    my ( $self ) = @_;

    return $self->errors_iterator->errors_hash;
}

sub _reset_errors {
    shift->errors_iterator->records([]);
}

=head2 faulty_fields

Accessor to the list of fields where the validator detected errors.

=cut

sub faulty_fields {
    my $self = shift;
    my @ffs;

    while (my $err = $self->errors_iterator->next) {
        push @ffs, $err->{field};
    }

    $self->errors_iterator->reset;

    return @ffs;
}

=head2 errors_as_hashref_for_humans

Accessor to get a list of the failed checks. It returns an hashref
with the keys set to the faulty fields, and the value as an arrayref
to a list of the error messages.

=cut

sub errors_as_hashref_for_humans {
    my $self = shift;
    return $self->_get_errors_field(1);
}

=head2 errors_as_hashref

Same as above, but for machine processing. It returns the lists of
error codes as values.

=cut

sub errors_as_hashref {
    my $self = shift;
    return $self->_get_errors_field(0);
}


=head2 packed_errors($fieldsep, $separator)

As convenience, this method will join the human readable strings using
the second argument, and introduced by the name of the field
concatenated to the first argument. Example with the defaults (colon
and comma):

  password: Wrong length, No special characters, No letters in the
  password, Found common password, Not enough different characters,
  Found common patterns: 1234
  country: My error
  email2: rfc822

In scalar context it returns a string, in list context returns the
errors as an array, so you still can process it easily.

=cut


sub packed_errors {
    my $self = shift;
    my $fieldsep = shift || ": ";
    my $separator = shift || ", ";

    my $errs = $self->errors_as_hashref_for_humans;
    my @out;
    # print Dumper($errs);
    foreach my $k ($self->faulty_fields) {
        push @out, $k . $fieldsep . join($separator, @{$errs->{$k}});
    }
    return wantarray ? @out : join("\n", @out);
}


sub _get_errors_field {
    my $self = shift;
    my $i = shift;
    my %errors;

    while (my $err = $self->errors_iterator->next) {
        my $f = $err->{field};
        $errors{$f} = [] unless exists $errors{$f};
        foreach my $string (@{$err->{errors}}) {
            push @{$errors{$f}}, $string->[$i];
        }
    }

    $self->errors_iterator->reset;

    return \%errors;
}

=head2 field_is_required($field)

Check if the field is required. Return true unconditionally if the
option C is set. If not, look into the schema and return
the value provided in the schema.

=cut


sub field_is_required {
    my ($self, $field) = @_;
    return unless defined $field;
    return 1 if $self->option("requireall");
    return $self->field($field)->required;
}

sub _build_object {
    my ($self, $name, $params) = @_;
    my $validator = $params->{validator};
    my $type = ref($validator);
    my $obj;
    # print "Building $name... " . Dumper($params);
    # if we got a string, the class is Data::Transpose::$string
    if ($type eq 'CODE') {
        $obj = Data::Transpose::Validator::Subrefs->new($validator);
    }
    else {
        my ($class, $classoptions);
        if ($type eq '') {
            my $module = $validator || "Base";
            die "No group is allowed here" if $module eq 'Group';
            $class = __PACKAGE__ . '::' . $module;
            # use options from params
            $classoptions = $params->{options} || {};
        }
        elsif ($type eq 'HASH') {
            $class = $validator->{class};
            die "Missing class for $name!" unless $class;
            unless ($validator->{absolute}) {
                die "No group is allowed here" if $class eq 'Group';
                $class = __PACKAGE__ . '::' . $class;
            }
            $classoptions = $validator->{options} || {};
            # print Dumper($classoptions);
        }
        else {
            die "Wrong usage. Pass a string, an hashref or a sub!\n";
        }
        # lazy loading, avoiding to load the same class twice
        try {
            $obj = $class->new(%$classoptions);
        } catch {
            load $class;
            $obj = $class->new(%$classoptions);
        };
    }
    if ($params->{options}) {
        $obj->dtv_options($params->{options});
    }
    if ($self->option('requireall') || $params->{required}) {
        $obj->required(1);
    }
    return $obj;
}

sub _strip_white {
    my ($self, $string) = @_;
    return unless defined $string;
    return $string unless (ref($string) eq ''); # scalars only
    return "" if ($string eq ''); # return the empty string
    $string =~ s/^\s+//;
    $string =~ s/\s+$//;
    return $string;
}

sub _collapse_white {
    my ($self, $string) = @_;
    return unless defined $string;
    return $string unless (ref($string) eq '');
    # convert all
    $string =~ s/\s+/ /gs;
    return $string;
}


sub _field_args_are_valid {
    my ($self, $field, @keys) = @_;
    my %valid = (
                 validator => 1,
                 name => 1,
                 required => 1,
                 options => 1,
                );
    foreach my $k (@keys) {
        unless ($valid{$k}) {
            die "$field has unrecognized option $k!\n";
        }
    }
}


=head2 reset_self

Clear all the internal data stored during validations, to make the
reusing of the transposing possible.

This is called by C before doing any other operation

=cut

sub reset_self {
    my $self = shift;
    $self->_set_success(undef);
    $self->_reset_errors;
}

1;

__END__