#!/usr/bin/perl -w
# Copyright (c) 1996-2014 Sullivan Beck. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.

# SB_TEST.PL
###############################################################################
# HISTORY
#
# 1996-??-??  Wrote initial version for Date::Manip module
#
# 1996-2001   Numerous changes
#
# 2001-03-29  Rewrote to make it easier to drop in for any module.
#
# 2001-06-19  Modifications to make space delimited stuff work better.
#
# 2001-08-23  Added support for undef args.
#
# 2007-08-14  Better support for undef/blank args.
#
# 2008-01-02  Better handling of $runtests.
#
# 2008-01-24  Better handling of undef/blank args when arguements are
#             entered as lists instead of strings.
#
# 2008-01-25  Created a global $testnum variable to store the test number
#             in.
#
# 2008-11-05  Slightly better handling of blank/undef in returned values.
#
# 2009-09-01  Added "-l" value to $runtests.
#
# 2009-09-30  Much better support for references.
#
# 2010-02-05  Fixed bug in passing tests as lists
#
# 2010-04-05  Renamed to testfunc.pl to avoid being called in a core module

###############################################################################

use Storable qw(dclone);

# Usage: test_Func($funcref,$tests,$runtests,@extra)=@_;
#
# This takes a series of tests, runs them, compares the output of the tests
# with expected output, and reports any differences.  Each test consists of
# several parts:
#    a function passed in as a reference ($funcref)
#    a series of arguments to be passed to the function
#    the expected output from the function call
#
# Tests may be passed in in two methods: as a string, or as a reference.
#
# Using the string case, $tests is a newline delimited string.  Each test
# takes one or more lines of the string.  Tests are separated from each
# other by a blank line.
#
# Arguments and return value(s) may be written as a single line:
#    ARG1 ARG2 ... ARGn ~ VAL1 VAL2 ... VALm
# or as multiple lines:
#    ARG1
#    ARG2
#    ...
#    ARGn
#    ~
#    VAL1
#    VAL2
#    ...
#    VALm
#
# If any of the arguments OR values have spaces in them, only the multiline
# form may be used.
#
# If there is exactly one return value, the separating tilde is
# optional:
#    ARG1 ARG2 ... ARGn VAL1
# or:
#    ARG1
#    ARG2
#    ...
#    ARGn
#    VAL
#
# It is valid to have a function with no arguments or with no return
# value (or both).  The "~" must be used:
#
#    ARG1 ARG2 ... ARGn ~
#
#    ~ VAL1 VAL2 ... VALm
#
#    ~
#
# Leading and trailing space is ignored in the multi-line format.
#
# If desired, any of the ARGs or VALs may be the word "_undef_" which
# will be strictly interpreted as the perl undef value. The word "_blank_"
# may also be used to designate a defined but empty string.
#
# They may also be (in the multiline format) of the form:
#
#   \ STRING           : a string reference
#
#   [] LIST            : a list reference (where LIST is a
#                        comma separated list)
#
#   [SEP] LIST         : a list reference (where SEP is a
#                        single character separator)
#
#   {} HASH            : a hash reference (where HASH is
#                        a comma separated list)
#
#   {SEP} HASH         : a hash reference (where SEP is a
#                        single character separator)
#
# Alternately, the tests can be passed in as a list reference:
#    $tests = [
#               [
#                 [ @ARGS1 ],
#                 [ @VALS1 ]
#               ],
#               [
#                 [ @ARGS2 ],
#                 [ @VALS2 ]
#               ], ...
#             ]
#
# @extra are extra arguments which are added to the function call.
#
# There are several ways to run the tests, depending on the value of
# $runtests.
#
# If $runtests is 0, the tests are run in a non-interactive way suitable
# for running as part of a "make test".
#
# If $runtests is a positive number, it runs runs all tests starting at
# that value in a way suitable for running interactively.
#
# If $runtests is a negative number, it runs all tests starting at that
# value, but providing feedback at each test.
#
# If $runtests is a string "=N" (where N is a number), it runs only
# that test.
#
# If $runtests is the string "-l", it lists the tests and the expected
# output without running any.

sub test_Func {
   my($funcref,$tests,$runtests,@extra)=@_;
   my(@tests);

   $runtests     = 0  if (! $runtests);
   my($starttest,$feedback,$endtest,$runtest);
   if      ($runtests eq "0"  or  $runtests eq "-0") {
      $starttest = 1;
      $feedback  = 1;
      $endtest   = 0;
      $runtest   = 1;
   } elsif ($runtests =~ /^\d+$/){
      $starttest = $runtests;
      $feedback  = 0;
      $endtest   = 0;
      $runtest   = 1;
   } elsif ($runtests =~ /^-(\d+)$/) {
      $starttest = $1;
      $feedback  = 1;
      $endtest   = 0;
      $runtest   = 1;
   } elsif ($runtests =~ /^=(\d+)$/) {
      $starttest = $1;
      $feedback  = 1;
      $endtest   = $1;
      $runtest   = 1;
   } elsif ($runtests eq "-l") {
      $starttest = 1;
      $feedback  = 1;
      $endtest   = 0;
      $runtest   = 0;
   } else {
      die "ERROR: unknown argument(s): $runtests";
   }

   my($tests_as_list) = 0;
   if (ref($tests) eq "ARRAY") {
      @tests   = @$tests;
      $tests_as_list = 1;

   } else {
      # Separate tests.

      my($comment)="#";
      my(@lines)=split(/\n/,$tests);
      my(@test);
      while (@lines) {
         my $line = shift(@lines);
         $line =~ s/^\s*//;
         $line =~ s/\s*$//;
         next  if ($line =~ /^$comment/);

         if ($line ne "") {
            push(@test,$line);
            next;
         }

         if (@test) {
            push(@tests,[ @test ]);
            @test=();
         }
      }
      if (@test) {
         push(@tests,[ @test ]);
      }

      # Get arg/val lists for each test.

      foreach my $test (@tests) {
         my(@tmp)=@$test;
         my(@arg,@val);

         # single line test
         @tmp = split(/\s+/,$tmp[0])  if ($#tmp == 0);

         my($sep)=-1;
         my($i);
         for ($i=0; $i<=$#tmp; $i++) {
            if ($tmp[$i] eq "~") {
               $sep=$i;
               last;
            }
         }

         if ($sep<0) {
            @val=pop(@tmp);
            @arg=@tmp;
         } else {
            @arg=@tmp[0..($sep-1)];
            @val=@tmp[($sep+1)..$#tmp];
         }
         $test = [ [@arg],[@val] ];
      }
   }

   my($ntest)=$#tests + 1;
   print "1..$ntest\n"  if ($feedback  &&  $runtest);

   my(@t);
   if ($endtest) {
      @t = ($starttest..$endtest);
   } else {
      @t = ($starttest..$ntest);
   }

   foreach my $t (@t) {
      $::testnum  = $t;

      my (@arg);
      if ($tests_as_list) {
         @arg     = @{ $tests[$t-1][0] };
      } else {
         my $arg  = dclone($tests[$t-1][0]);
         @arg     = @$arg;
         print_to_vals(\@arg);
      }

      my $argprt  = dclone(\@arg);
      my @argprt  = @$argprt;
      vals_to_print(\@argprt);

      my $exp     = dclone($tests[$t-1][1]);
      my @exp     = @$exp;
      print_to_vals(\@exp);
      vals_to_print(\@exp);

      # Run the test

      my ($ans,@ans);
      if ($runtest) {
         @ans = &$funcref(@arg,@extra);
      }
      vals_to_print(\@ans);

      # Compare the results

      foreach my $arg (@arg) {
         $arg = "_undef_"  if (! defined $arg);
         $arg = "_blank_"  if ($arg eq "");
      }
      $arg = join("\n           ",@argprt,@extra);
      $ans = join("\n           ",@ans);
      $exp = join("\n           ",@exp);

      if (! $runtest) {
         print "########################\n";
         print "Test     = $t\n";
         print "Args     = $arg\n";
         print "Expected = $exp\n";
      } elsif ($ans ne $exp) {
         print "not ok $t\n";
         warn "########################\n";
         warn "Args     = $arg\n";
         warn "Expected = $exp\n";
         warn "Got      = $ans\n";
         warn "########################\n";
      } else {
         print "ok $t\n"  if ($feedback);
      }
   }
}

# The following is similar but it takes input from an input file and
# sends output to an output file.
#
# $files is a reference to a list of tests.  If one of the tests is named
# "foobar", the input is from "foobar.in", output is to "foobar.out", and
# the expected output is in "foobar.exp".
#
# The function stored in $funcref is called as:
#    &$funcref($in,$out,@extra)
# where $in is the name of the input file, $out is the name of the output
# file, and @extra are any additional arguments that are required.
#
# The function should return 0 on success, or an error message.

sub test_File {
   my($funcref,$files,$runtests,@extra)=@_;
   my(@files)=@$files;

   $runtests=0  if (! $runtests);

   my($ntest)=$#files + 1;
   print "1..$ntest\n"  if (! $runtests);

   my(@t);
   if ($runtests > 0) {
      @t = ($runtests..$ntest);
   } elsif ($runtests < 0) {
      @t = (-$runtests);
   } else {
      @t = (1..$ntest);
   }

   foreach my $t (@t) {
      $::testnum = $t;
      my $test = $files[$t-1];
      my $expf = "$test.exp";
      my $outf = "$test.out";

      if (! -f $test  ||  ! -f $expf) {
         print "not ok $t\n";
         warn  "Test: $test: missing input/outpuf information\n";
         next;
      }

      my $err  = &$funcref($test,$outf,@extra);
      if ($err) {
         print "not ok $t\n";
         warn  "Test: $test: $err\n";
         next;
      }

      local *FH;
      open(FH,$expf)  ||  do {
         print "not ok $t\n";
         warn  "Test: $test: $!\n";
         next;
      };
      my @exp = <FH>;
      close(FH);
      my $exp = join("",@exp);
      open(FH,$outf)  ||  do {
         print "not ok $t\n";
         warn  "Test: $test: $!\n";
         next;
      };
      my @out = <FH>;
      close(FH);
      my $out = join("",@out);

      if ($out ne $exp) {
         print "not ok $t\n";
         warn  "Test: $test: output differs from expected value\n";
         next;
      }

      print "ok $t\n"  if (! $runtests);
   }
}

# Converts a printable version of arguments to actual arguments
sub print_to_vals {
   my($listref) = @_;

   foreach my $arg (@$listref) {
      next  if (! defined($arg));
      if ($arg eq "_undef_") {
         $arg = undef;

      } elsif ($arg eq "_blank_") {
         $arg = "";

      } elsif ($arg =~ /^\\\s*(.*)/) {
         $str = $1;
         $arg = \$str;

      } elsif ($arg =~ /^\[(.?)\]\s*(.*)/) {
         my($sep,$str) = ($1,$2);
         $sep = ","  if (! $sep);
         my @list = split(/\Q$sep\E/,$str);
         foreach my $e (@list) {
            $e = ""     if ($e eq "_blank_");
            $e = undef  if ($e eq "_undef_");
         }
         $arg = \@list;

      } elsif ($arg =~ /^\{(.?)\}\s*(.*)/) {
         my($sep,$str) = ($1,$2);
         $sep = ","  if (! $sep);
         my %hash = split(/\Q$sep\E/,$str);
         foreach my $key (keys %hash) {
            my $val = $hash{$key};
            $hash{$key} = undef  if ($val eq "_undef_");
            $hash{$key} = ""     if ($val eq "_blank_");
         }
         $arg = \%hash;
      }
   }
}

# Converts arguments to a printable version.
sub vals_to_print {
   my($listref) = @_;

   foreach my $arg (@$listref) {
      if (! defined $arg) {
         $arg = "_undef_";

      } elsif (! ref($arg)) {
         $arg = "_blank_"  if ($arg eq "");

      } else {
         my $ref = ref($arg);
         if      ($ref eq "SCALAR") {
            $arg = "\\ $$arg";

         } elsif ($ref eq "ARRAY") {
            my @list = @$arg;
            foreach my $e (@list) {
               $e = "_undef_", next   if (! defined($e));
               $e = "_blank_"         if ($e eq "");
            }
            $arg = join(" ","[",join(", ",@list),"]");

         } elsif ($ref eq "HASH") {
            %hash = %$arg;
            foreach my $key (keys %hash) {
               my $val = $hash{$key};
               $hash{$key} = "_undef_", next  if (! defined($val));
               $hash{$key} = "_blank_"        if ($val eq "_blank_");
            }
            $arg = join(" ","{",
                        join(", ",map { "$_ => $hash{$_}" }
                             (sort keys %hash)), "}");
            $arg =~ s/  +/ /g;
         }
      }
   }
}

1;
# Local Variables:
# mode: cperl
# indent-tabs-mode: nil
# cperl-indent-level: 3
# cperl-continued-statement-offset: 2
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
# cperl-label-offset: -2
# End: