File Coverage

lib/Test/Easy/DataDriven.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package Test::Easy::DataDriven;
use base qw(Exporter);

use strict;
use warnings;

use Carp qw(confess);
use Test::Easy::DeepEqual qw(deep_equal);
use Scalar::Util qw(blessed);
use Hash::MostUtils qw(lkeys);
use Functional::Utility qw(hook_run y_combinator);

our @EXPORT = qw(run_where each_ok);

sub assert(&;$) {
  require Carp;
  Carp::confess pop() if ! shift->();
}

sub run_where {
  my $code = pop;
  my (@where) = @_;

  return y_combinator {
    my ($recurse) = @_;
    return sub {
      my $where = shift @where;
      my $to_run = scalar @where ? $recurse : $code;
      return run_then_restore(@$where, $to_run);
    };
  }->();
}

sub run_then_restore {
  my $code = pop;
  my (@args) = @_;

  assert { ! grep { ! ref($_) } lkeys @args } "error: you gave me a bare scalar - give me a scalar reference instead";

  my @restore;

  my %sg = (
    SCALAR => [
      sub {
        my ($r, $v) = @_;
        $$r = $v;
      },
      sub {
        my ($r, $v) = @_;
        return $$r;
      },
    ],
    ARRAY => [
      sub {
        my ($r, $v) = @_;
        $r = $$r if ref($r) eq 'REF';
        @$r = @$v;
      },
      sub {
        my ($r, $v) = @_;
        return [@$r];
      },
    ],
    HASH => [
      sub {
        my ($r, $v) = @_;
        $r = $$r if ref($r) eq 'REF';
        %$r = %$v;
      },
      sub {
        my ($r, $v) = @_;
        return +{%$r};
      },
    ],
  );

  return hook_run(
    before => sub {
      while (my ($r, $v) = splice @args, 0, 2) {
        my ($setter, $getter) = @{$sg{ref $r} || $sg{SCALAR}};
        push @restore, {ref => $r, value => $getter->($r, $v)};
        $setter->($r, $v);
      }
    },
    run => $code,
    after => sub {
      foreach (@restore) {
        my ($setter) = @{$sg{ref $_->{value}} || $sg{SCALAR}};
        $setter->($_->{ref}, $_->{value});
      }
    },
  );
}

sub each_ok (&@) {
  my $code = shift;

  local $_;

  my $index = 0;

  my @bad;
  foreach (@_) {
    my $orig = $_;
    my (@got) = $code->();

    my $ok = 1;
    my $expected;

    if (@got == 1) {
      $ok = !! $got[0];
      $expected = 'something true';
    } elsif (! _match($got[0], $got[1])) {
      $ok = 0;
      $expected = $got[1];
    }

    push @bad, {
      raw => $_,
      index => $index,
      got => $got[0],
      expected => $expected,
    } if ! $ok;

    $index++;
  }

  local $Test::Builder::Level = $Test::Builder::Level + 1;
  return Test::Easy::deep_ok( \@bad, [] );
}

sub _match {
  my ($got, $expected) = @_;
  if (ref($expected) eq 'Regexp') {
    return $got =~ $expected;
  } elsif (! scalar grep { ref } ($got, $expected)) {
    return $got eq $expected;
  } elsif (ref($got) eq ref($expected)) {
    return deep_equal($got, $expected);
  } else {
    confess "I don't know how to compare a '${\ref($got)}' to a '${\ref($expected)}'";
  }
}

1;

__END__