#!/usr/bin/perl -w

# Copyright (c) 1996-2018 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: 0

# End: