File Coverage

blib/lib/Test/Deep/HashRec.pm

Criterion	Covered	Total	%
statement	50	60	83.3
branch	9	18	50.0
condition	2	4	50.0
subroutine	8	9	88.8
pod	1	1	100.0
total	70	92	76.0

use strict;
use warnings;

package Test::Deep::HashRec 0.004;
# ABSTRACT:  test hash entries for required and optional fields

#pod =func hashrec
#pod
#pod   cmp_deeply(
#pod     $got,
#pod     hashrec({
#pod       required => { count => any(1,2,3), b => ignore() },
#pod       optional => { name  => { first => ignore(), last => ignore() } },
#pod     }),
#pod     "we got a valid record",
#pod   );
#pod
#pod C returns a Test::Deep comparator that asserts that:
#pod
#pod =for :list
#pod * all required elements are present
#pod * nothing other than required and optional elements are present
#pod * all present elements match the comparator given for them
#pod
#pod If you pass a true C argument, then unknown elements will be
#pod permitted, and their values ignored.
#pod
#pod =cut

use Exporter 'import';

our @EXPORT = qw(hashrec);

sub hashrec { Test::Deep::HashRec::Object->new(@_) };

{
package
  Test::Deep::HashRec::Object;

use Test::Deep::Cmp;
use Test::Deep::HashElements;

sub init {
  my ($self, $val) = @_;

  Carp::confess("argument to hashrec must be a hash reference")
    unless ref $val eq 'HASH';

  my %copy = %$val;

  $self->{required}       = delete $copy{required} || {};
  $self->{optional}       = delete $copy{optional} || {};
  $self->{allow_unknown}  = delete $copy{allow_unknown};

  $self->{is_permitted} = {
    map {; $_ => 1 } (keys %{ $self->{required} }, keys %{ $self->{optional} })
  };

  $self->{diagnostics} = [];

  Carp::confess("unknown arguments to hashrec: " . join q{, }, keys %copy)
    if keys %copy;

  my @dupes = grep {; exists $self->{required}{$_} }
              keys %{ $self->{optional} };

  Carp::confess("Keys found in both optional and required: @dupes")
    if @dupes;

  return;
}

sub diagnostics {
  my ($self, $where, $last) = @_;

  (my $error = $self->{diag}) =~ s/^/  /gm;
  my $diag  = <
In hash record $where
$error
EOM

  return $diag;
}

sub descend {
  my ($self, $got) = @_;

  undef $self->{diag};

  unless (ref $got eq 'HASH') {
    $self->{diag} = "Didn't get a hash reference";
    return
  }

  my @keys = keys %$got;

  my @errors;

  unless ($self->{allow_unknown}) {
    my @unknown = grep {; ! exists $self->{is_permitted}{$_} } @keys;
    if (@unknown) {
      push @errors, "Unknown keys found: @unknown";
    }
  }

  if (my @missing = grep {; ! exists $got->{$_} } keys %{ $self->{required}}) {
    push @errors, "Missing required keys: @missing";
  }

  if (@errors) {
    $self->{diag} = join qq{\n}, @errors;
    return;
  }

  my %effective = (
    map   {; $_ => (exists $self->{required}{$_}  ? $self->{required}{$_}
                                                  : $self->{optional}{$_}) }
    grep  {; $self->{is_permitted}{$_} }
    keys %$got
  );

  return Test::Deep::descend(
    $got,
    Test::Deep::HashElements->new(\%effective),
  );
}

}

1;

__END__