File Coverage

blib/lib/Config/Validate.pm

Criterion	Covered	Total	%
statement	268	272	98.5
branch	124	126	98.4
condition	27	30	90.0
subroutine	42	44	95.4
pod	5	5	100.0
total	466	477	97.6

package Config::Validate;

use strict;
use warnings;
use 5.008005;

# There is too much DWIMery here for this to be practical
## no critic (RequireArgUnpacking, ProhibitDoubleSigils)

{
  use Object::InsideOut;

  use Data::Dumper;
  use Clone::PP qw(clone);
  use Scalar::Util qw(blessed);
  use Params::Validate qw(:types validate_with);
  use Carp::Clan;
  use List::MoreUtils qw(any);

  use Exporter qw(import);
  our @EXPORT_OK = qw(validate mkpath);
  our %EXPORT_TAGS = ('all' => \@EXPORT_OK);

  our $VERSION = '0.2.6';

  my @schema              :Field
                          :Accessor(schema)
                          :Arg(schema);
  my @array_allows_scalar :Field
                          :Accessor(array_allows_scalar)
                          :Arg(array_allows_scalar)
                          :Default(1);
  my @debug               :Field
                          :Accessor(debug)
                          :Arg(debug);
  my @on_debug            :Field
                          :Accessor(on_debug)
                          :Arg(on_debug)
                          :Default(\&_debug_print);
  my @data_path           :Field
                          :Accessor(data_path)
                          :Arg(data_path)
                          :Default(0);
  my @data_path_options   :Field
                          :Accessor(data_path_options)
                          :Arg(data_path_options)
                          :Default( {} );

  my @types               :Field;

  ## no critic(ProhibitSubroutinePrototypes)
  sub _throw (@);
  ## use critic

  my %default_types = (
    integer   => { validate => \&_validate_integer },
    float     => { validate => \&_validate_float },
    string    => { validate => \&_validate_string },
    boolean   => { validate => \&_validate_boolean },
    hash      => { validate => \&_validate_hash },
    array     => { validate => \&_validate_array,
                   byreference => 1,
                 },
    directory => { validate => \&_validate_directory },
    file      => { validate => \&_validate_file },
    domain    => { validate => \&_validate_domain },
    hostname  => { validate => \&_validate_hostname },
    nested    => { validate => sub { _throw "'nested' is not valid here"; }},
  );

  my %types = %default_types;

  my $have_data_path;

  sub _init :Init {
    my ($self, $args) = @_;

    $types[$$self] = clone(\%types);

    unless (defined $have_data_path) {
      eval { require Data::Path; };
      $have_data_path = $@ eq '' ? 1 : 0;
    }

    if ($self->data_path and not $have_data_path) {
      _throw "Data::Path requested, but cannot find module";
    }

    return;
  }

  sub _parse_add_type_params {
    # TODO: This should be updated to allow 'byreference'
    my $spec = { name => { type => SCALAR },
                 validate => { type => CODEREF,
                               optional => 1,
                             },
                 init     => { type => CODEREF,
                               optional => 1,
                             },
                 finish   => { type => CODEREF,
                               optional => 1,
                             },
               };
    return validate_with(params         => \@_,
                         spec           => $spec,
                         stack_skip     => 2,
                         normalize_keys => sub {
                           return lc $_[0];
                         },
                        );
  }

  sub add_default_type {
    # this is a function, but if it's called as a method, that's
    # fine too.
    my $self;
    if (@_) {
      $self = shift if blessed $_[0];
      shift if $_[0] eq 'Config::Validate';
    }

    my %p = _parse_add_type_params(@_);
    if ($self) {
      $self->add_type(%p);
    }

    if (defined $types{$p{name}}) {
      _throw "Attempted to add type '$p{name}' that already exists";
    }

    my $type = clone(\%p);
    delete $type->{name};
    if (keys %$type == 0) {
      _throw "No callbacks defined for type '$p{name}'";
    }
    $types{$p{name}} = $type;


    return;
  }

  sub add_type {
    my $self = shift;
    my %p = _parse_add_type_params(@_);

    if (defined $types[$$self]{$p{name}}) {
      _throw "Attempted to add type '$p{name}' that already exists";
    }

    my $type = clone(\%p);
    delete $type->{name};
    if (keys %$type == 0) {
      _throw "No callbacks defined for type '$p{name}'";
    }
    $types[$$self]{$p{name}} = $type;
    return;
  }

  sub reset_default_types {
    %types = %default_types;
    return;
  }

  sub _type_callback {
    my ($self, $callback, @args) = @_;

    while (my ($name, $value) = each %{ $types[$$self] }) {
      if (defined $value->{$callback}) {
        $value->{$callback}(@args);
      }
    }
    return;
  }

  # Unfortunately, the validate function/method used to not use
  # Params::Validate, and used to instead be callable as a one
  # argument version as an instance method, or a two argument version
  # (schema and config) as a function.  This functin is to detect
  # which way it is being called, and normalize the argument list.
  sub _parse_validate_args {
    my (@args) = @_;

    if (@args < 2) {
      _throw "Config::Validate::validate requires at least two arguments";
    }

    my $self;
    if (blessed $args[0]) {
      # called as a method
      $self = shift @args;
      if (@args == 1) {
        @args = (schema => $schema[$$self],
                 config => $args[0]);
      } else {
        push(@args, schema => $self->schema);
      }
    } else {
      $self = Config::Validate->new();
      if (@args == 2) {
        @args = (config => $args[0],
                 schema => $args[1]);
      }
    }

    my $spec = { schema => { type => HASHREF },
                 config => { type => HASHREF },
               };
    my %args = validate_with(params         => \@args,
                             spec           => $spec,
                             stack_skip     => 2,
                             normalize_keys => sub {
                               return lc $_[0];
                             },
                            );

    return ($self, %args);
  }

  sub validate {
    my ($self, %args) = _parse_validate_args(@_);
    my ($config, $schema) = (clone($args{config}),
                             clone($args{schema}));

    # Not sure if Config::General object will be extended or not, so
    # assume anything in Config::General namespace as a getall method.
    my $config_type = ref $config;
    if ($config_type =~ /^Config::General/ix) {
      $config = { $config->getall() };
    }

    $self->_type_callback('init', $self, $schema, $config);
    $self->_validate($config, $schema, []);
    $self->_type_callback('finish', $self, $schema, $config);

    if ($self->data_path) {
      return Data::Path->new($config, $self->data_path_options);
    }
    return $config;
  }

  sub _validate {
    my ($self, $cfg, $schema, $path) = @_;

    $schema = clone($schema);
    my $orig = clone($cfg);

    while (my ($canonical_name, $def) = each %$schema) {
      my @curpath = (@$path, $canonical_name);
      my @names = _get_aliases($canonical_name, $def, @curpath);
      $self->_check_definition_type($def, @curpath);

      my $found = 0;
      foreach my $name (@names) {
        next unless defined $cfg->{$name};

        if ($name ne $canonical_name) {
          $cfg->{$canonical_name} = $cfg->{$name};
          delete $cfg->{$name};
          delete $orig->{$name};
        }

        $self->_debug("Validating ", mkpath(@curpath));
        if (lc($def->{type}) eq 'nested') {
          $self->_validate($cfg->{$canonical_name}, $schema->{$name}{child}, \@curpath);
        } else {
          $self->_invoke_validate_callback($cfg, $canonical_name, $def, \@curpath);
        }

        if (defined $def->{callback}) {
          if (ref $def->{callback} ne 'CODE') {
            _throw sprintf("%s: callback specified is not a code reference",
                        mkpath(@curpath));
          }
          $def->{callback}($self, $cfg->{$canonical_name}, $def, \@curpath);
        }
        $found++;
      }

      if (not $found and defined $def->{default}) {
        $cfg->{$canonical_name} = $def->{default};
        $found++;
      }

      delete $orig->{$canonical_name};

      if (not $found and (not defined $def->{optional} or not $def->{optional})) {
        _throw "Required item " . mkpath(@curpath) . " was not found";
      }
    }

    my @unknown = sort keys %$orig;
    if (@unknown != 0) {
      _throw sprintf("%s: the following unknown items were found: %s",
                  mkpath($path), join(', ', @unknown));
    }

    return;
  }

  sub _invoke_validate_callback {
    my ($self, $cfg, $canonical_name, $def, $curpath) = @_;

    my $typeinfo = $types[$$self]{$def->{type}};
    my $callback = $typeinfo->{validate};

    if (not defined $callback) {
      _throw("No callback defined for type '$def->{type}'");
    }

    if ($typeinfo->{byreference}) {
      $callback->($self, \$cfg->{$canonical_name}, $def, $curpath);
    } else {
      $callback->($self,  $cfg->{$canonical_name}, $def, $curpath);
    }

    return;
  }

  sub _get_aliases {
    my ($canonical_name, $definition, @curpath) = @_;

    my @names = ($canonical_name);
    if (defined $definition->{alias}) {
      if (ref $definition->{alias} eq 'ARRAY') {
        push(@names, @{$definition->{alias}});
      } elsif (ref $definition->{alias} eq '') {
        push(@names, $definition->{alias});
      } else {
        _throw sprintf("Alias defined for %s is type %s, but must be " .
                      "either an array reference, or scalar",
                      mkpath(@curpath), ref $definition->{alias},
                     );
      }
    }
    return @names;
  }

  sub _check_definition_type {
    my ($self, $definition, @curpath) = @_;
    if (not defined $definition->{type}) {
      _throw "No type specified for " . mkpath(@curpath);
    }

    if (not defined $types[$$self]{$definition->{type}}) {
      _throw "Invalid type '$definition->{type}' specified for ",
        mkpath(@curpath);
    }

    return;
  }

  # TODO: Make this callable as a method or function
  sub mkpath {
    @_ = @{$_[0]} if ref $_[0] eq 'ARRAY';

    return '[/' . join('/', @_) . ']';
  }

  sub _validate_hash {
    my ($self, $value, $def, $path) = @_;

    if (not defined $def->{keytype}) {
      _throw "No keytype specified for " . mkpath(@$path);
    }

    if (not defined $types[$$self]{$def->{keytype}}) {
      _throw "Invalid keytype '$def->{keytype}' specified for " . mkpath(@$path);
    }

    if (ref $value ne 'HASH') {
      _throw sprintf("%s: should be a 'HASH', but instead is '%s'",
                  mkpath($path), ref $value);
    }

    while (my ($k, $v) = each %$value) {
      my @curpath = (@$path, $k);
      $self->_debug("Validating ", mkpath(@curpath));
      my $callback = $types[$$self]{$def->{keytype}}{validate};
      $callback->($self, $k, $def, \@curpath);
      if ($def->{child}) {
        $self->_validate($v, $def->{child}, \@curpath);
      }
    }
    return;
  }

  sub _validate_array {
    my ($self, $value, $def, $path) = @_;

    if (not defined $def->{subtype}) {
      _throw "No subtype specified for " . mkpath(@$path);
    }

    if (not defined $types[$$self]{$def->{subtype}}) {
      _throw "Invalid subtype '$def->{subtype}' specified for " . mkpath(@$path);
    }

    if (ref $value eq 'SCALAR' and $array_allows_scalar[$$self]) {
      $$value = [ $$value ];
      $value = $$value;
    } elsif (ref $value eq 'REF' and ref $$value eq 'ARRAY') {
      $value = $$value;
    }

    if (ref $value ne 'ARRAY') {
      _throw sprintf("%s: should be an 'ARRAY', but instead is a '%s'",
                  mkpath($path), ref $value);
    }

    my $index = 0;
    foreach my $item (@$value) {
      my @path = ( @$path, "[$index]" );
      $self->_debug("Validating ", mkpath(@path));
      my $callback = $types[$$self]{$def->{subtype}}{validate};
      $callback->($self, $item, $def, \@path);
      $index++;
    }
    return;
  }

  sub _validate_integer {
    my ($self, $value, $def, $path) = @_;
    if ($value !~ /^ -? \d+ $/xo) {
      _throw sprintf("%s should be an integer, but has value of '%s' instead",
                  mkpath($path), $value);
    }
    if (defined $def->{max} and $value > $def->{max}) {
      _throw sprintf("%s: %d is larger than the maximum allowed (%d)",
                  mkpath($path), $value, $def->{max});
    }
    if (defined $def->{min} and $value < $def->{min}) {
      _throw sprintf("%s: %d is smaller than the minimum allowed (%d)",
                  mkpath($path), $value, $def->{max});
    }

    return;
  }

  sub _validate_float {
    my ($self, $value, $def, $path) = @_;
    if ($value !~ /^ -? \d*\.?\d+ $/xo) {
      _throw sprintf("%s should be an float, but has value of '%s' instead",
                  mkpath($path), $value);
    }
    if (defined $def->{max} and $value > $def->{max}) {
      _throw sprintf("%s: %f is larger than the maximum allowed (%f)",
                  mkpath($path), $value, $def->{max});
    }
    if (defined $def->{min} and $value < $def->{min}) {
      _throw sprintf("%s: %f is smaller than the minimum allowed (%f)",
                  mkpath($path), $value, $def->{max});
    }

    return;
  }

  sub _validate_string {
    my ($self, $value, $def, $path) = @_;

    if (defined $def->{maxlen}) {
      if (length($value) > $def->{maxlen}) {
        _throw sprintf("%s: length of string is %d, but must be less than %d",
                    mkpath($path), length($value), $def->{maxlen});
      }
    }
    if (defined $def->{minlen}) {
      if (length($value) < $def->{minlen}) {
        _throw sprintf("%s: length of string is %d, but must be greater than %d",
                    mkpath($path), length($value), $def->{minlen});
      }
    }
    if (defined $def->{regex}) {
      if ($value !~ $def->{regex}) {
        _throw sprintf("%s: regex (%s) didn't match '%s'", mkpath($path),
                    $def->{regex}, $value);
      }
    }

    return;
  }

  sub _validate_boolean {
    my ($self, $value, $def, $path) = @_;

    my @true  = qw(y yes t true on);
    my @false = qw(n no f false off);
    $value =~ s/\s+//xg;
    $value = 1 if any { lc($value) eq $_ } @true;
    $value = 0 if any { lc($value) eq $_ } @false;

    if ($value !~ /^ [01] $/x) {
      _throw sprintf("%s: invalid value '%s', must be: %s", mkpath($path),
                  $value, join(', ', (0, 1, @true, @false)));
    }

    return;
  }

  sub _validate_directory {
    my ($self, $value, $def, $path) = @_;

    if (not -d $value) {
      _throw sprintf("%s: '%s' is not a directory", mkpath($path), $value)
    }
    return;
  }

  sub _validate_file {
    my ($self, $value, $def, $path) = @_;

    if (not -f $value) {
      _throw sprintf("%s: '%s' is not a file", mkpath($path), $value);
    }
    return;
  }

  sub _validate_domain {
    my ($self, $value, $def, $path) = @_;

    use Data::Validate::Domain qw(is_domain);

    my $rc = is_domain($value, { domain_allow_single_label => 1,
                                 domain_private_tld => qr/.*/x,
                                }
                      );
    if (not $rc) {
      _throw sprintf("%s: '%s' is not a valid domain name.",
                     mkpath($path), $value);
    }
    return;
  }

  sub _validate_hostname {
    my ($self, $value, $def, $path) = @_;

    use Data::Validate::Domain qw(is_hostname);

    my $rc = is_hostname($value, { domain_allow_single_label => 1,
                                   domain_private_tld => qr/\. acmedns $/xi,
                                  }
                      );
    if (not $rc) {
      _throw sprintf("%s: '%s' is not a valid hostname.",
                     mkpath($path), $value);
    }

    return;
  }

  sub _debug {
    my $self = shift;

    return unless $debug[$$self];
    return $on_debug[$$self]->($self, @_);
  }

  sub _debug_print {
    my $self = shift;

    print join('', @_), "\n";
    return;
  }

  ## no critic
  sub _throw (@) {
    # Turn off O::IO exception handler
    local $SIG{__DIE__};
    croak @_;
  }
  ## use critic

}
1;

__END__