#!/usr/bin/perl

# regression test suite for tsh

use strict;
use warnings;
use POSIX ":sys_wait_h";

use IPC::Open3;
use IO::Select;

our($opt_p);

sub Clean ($);
sub CompareReceived ($$$$);
sub Main ();
sub RunTSH ($$$$$);
sub SplitLines ($);
sub WriteConfig ($$);
sub WriteIFile ($$$);

Main;

sub Clean ($) {
  my $dir = shift;
  return if $opt_p;
  unlink <$dir/old/*>, <$dir/html/*>, <$dir/*>;
  rmdir "$dir/old";
  rmdir "$dir/html";
  rmdir $dir or die "Cannot rmdir $dir: $!";
  }

sub CompareReceived ($$$$) {
  my $expect = shift;
  my $gotp = shift;
  my $nonl = shift;
  my $filename = shift;
  my $error = 0;

  my (@expect) = split(/\015?\012/, $expect . ' ');
  pop @expect;
  my $diff = @expect - @$gotp;
  if (@expect > @$gotp) {
    print STDERR "\n" unless $nonl;
    printf STDERR "* Expected %d more line%s than received (%d) for %s:\n", $diff,
      $diff > 1 ? 's' : '', scalar(@$gotp), $filename;
#   print STDERR map { "$_\n" } @expect[0..$#$gotp];
#   print STDERR "--- and then ---\n";
    print STDERR map { "$_\n" } @expect[@$gotp..$#expect];
    $error++;
    }
  elsif (@expect < @$gotp) {
    print STDERR "\n" unless $nonl;
    printf STDERR "* Received %d more line%s than expected (%d)  for %s:\n", -$diff,
      $diff < -1 ? 's' : '', scalar(@expect), $filename;
    print STDERR map { "$_\n" } @{$gotp}[@expect..$#$gotp];
    $error++;
    }
  for my $i (0..(@expect > @$gotp ? @$gotp : @expect)-1) {
    if ($expect[$i] ne $gotp->[$i]) {
      my $col = '?';
      my $gotchars = '[none]';
      my $expectchars = '';
      for my $j (0..length($expect[$i])) {
	if ($j > length($gotp->[$i])) { 
	  $col = $j + 1;
	  last;
	  }
	elsif (substr($expect[$i], $j, 1) ne substr($gotp->[$i], $j, 1)) {
	  $col = $j + 1;
	  $gotchars = substr($gotp->[$i], $j, 20);
	  $expectchars = substr($expect[$i], $j, 20);
	  last;
	  }
        }
      print STDERR "\n" unless $nonl;
      $gotchars = sprintf('0x%02x', ord($gotchars)) unless $gotchars =~ /[ -~]/;
      $expectchars = sprintf('0x%02x', ord($expectchars)) unless $expectchars =~ /[ -~]/;
      printf STDERR "* Did not receive expected text for %s at line %d column $col (got '%s', wanted '%s').\n", $filename,  $i+1, $gotchars, $expectchars;
      print STDERR "** Wanted:   ", $expect[$i], "\n";
      print STDERR "** Received: ", $gotp->[$i], "\n";
      $error++;
      last;
      }
    }
  return $error;
  }

sub Main () {
  my $serial = time;
  my $testdir = 'test.' . $serial;
  my $testname = 'unnamed test';
  my %failed;
  my $config;
  my %ifiles;
  my $buffer;
  my $ifilename = undef;
  my $ofilename = undef;
  my $commands;
  my $stdout;
  my $stderr;
  my $timeout = 5;
  my $error = 0;
  my %ofiles;
  if (@::ARGV) {
    if ($::ARGV[0] eq '-p') {
      $opt_p = 1;
      shift @::ARGV;
      }
    }
  unless (@::ARGV) {
    @::ARGV = glob('lib/test/*');
    }
  while (<>) {
    if (/^#begintest\s+(.*)/) { $testname = $1; goto resetall; }
    elsif (/^#endtest\s*$/) {
      print STDERR "+ Running test '$testname'... ";
      $testdir = 'test.' . ++$serial  if $opt_p;
      mkdir $testdir or die "Cannot create $testdir: $!";
      WriteConfig $testdir, $config;
      while (my ($iname, $idata) = each %ifiles) {
	WriteIFile $testdir, $iname, $idata;
        }
      my $thiserror = RunTSH $testdir, $commands, $stdout, $stderr, $timeout;
      for my $ofile (sort keys %ofiles) {
	if (open my $fh, "<$testdir/$ofile") {
	  my (@got) = <$fh>;
	  for my $line (@got) { $line =~ s/[\015\012]+$//; }
	  close $fh;
	  $thiserror += CompareReceived $ofiles{$ofile}, \@got, $thiserror, $ofile;
	  }
	else {
	  print STDERR "\n" unless $thiserror++;
	  print STDERR "cannot open '$ofile': $!\n";
	  }
        }
      if ($thiserror) {
	warn "failed\n";
	$failed{$testname}++;
	$error += $thiserror;
        }
      else {
	warn "ok\n";
        }

      Clean $testdir;
      goto resetall;
      }
    elsif (/^#beginconfig\s*$/) { $buffer = '';}
    elsif (/^#endconfig\s*$/) { $config = $buffer; }
    elsif (/^#begincommands\s*$/) { $buffer = ''; }
    elsif (/^#endcommands\s*$/) { $commands = $buffer; }
    elsif (/^#beginstdout\s*$/) { $buffer = ''; }
    elsif (/^#endstdout\s*$/) { $stdout = $buffer; }
    elsif (/^#beginstderr\s*$/) { $buffer = ''; }
    elsif (/^#endstderr\s*$/) { $stderr = $buffer; }
    elsif (/^#beginofile\s+(\S.*\S)$/) { $buffer = ''; $ofilename = $1; }
    elsif (/^#endofile\s*$/) { 
      $ofiles{$ofilename} = $buffer;
      $ofilename = undef;
      }
    elsif (/^#beginifile\s+(\S+)\s*$/) { $buffer = ''; $ifilename = $1; }
    elsif (/^#endifile\s*$/) {
      die "#endifile without matching #beginifile" unless defined $ifilename;
      $ifiles{$ifilename} = $buffer;
      $ifilename = undef;
      }
    elsif (s/^##/#/) {
      $buffer .= $_; 
      }
    elsif (/^#timeout\s*(\d+)\s*$/) {
      $timeout = $1;
      }
    elsif (/^#/) {
      die "Unknown directive in $::ARGV: $_\n";
      }
    else { $buffer .= $_; }
    next;
    resetall:
      $config = '';
      %ifiles = ();
      $buffer = '';
      %ofiles = ();
      $ifilename = undef;
      $ofilename = undef;
      $commands = '';
      $stdout = '';
      $stderr = '';
    }
  if ($error) {
    warn "+ Some tests failed: " . join(', ', keys %failed) . "\n";
    }
  else {
    warn "+ All tests successful.\n";
    }
  }

sub RunTSH ($$$$$) {
  my $dir = shift;
  my $commands = shift;
  my $stdout = shift;
  my $stderr = shift;
  my $timeout = shift;
  my $error = 0;
  my $command = $^O eq 'MSWin32' 
    ? "perl tsh.pl $dir"
    : "./tsh.pl $dir";
  $::SIG{'PIPE'} = sub { die "SIGPIPE"; };
  my $pid = open3(*TOTSH, *FROMTSH, *ERRTSH, $command);
  my (%fromtsh) = ('stdout' => '', 'stderr' => '');
  my $timedout = 0;

  my $read_ports = new IO::Select(*FROMTSH, *ERRTSH);
  my $write_ports = new IO::Select(*TOTSH);
  my (%which_read) = (fileno(*FROMTSH) => 'stdout', fileno(*ERRTSH) => 'stderr');
  my $ports_left = 3;
  while ($ports_left) {
    my ($can_read, $can_write, $can_err) 
      = IO::Select::select($read_ports,
  	  length($commands) ? $write_ports : undef,
	  undef,
	  $timeout
	);
    unless (defined $can_err) {
      warn "\nselect() failed (could be timeout too short): $!";
      $error++;
      last;
      }
    my $did_something = 0;
    for my $fh (@$can_read) {
      my $which = $which_read{fileno($fh)};
      die "\nUnknown file handle: $fh" unless $which;
      my $buffer = '';
      my $count = sysread($fh, $buffer, 4096, 0);
      unless (defined $count) {
	die "\nsysread(tsh stdout) failed: $!";
	}
      unless ($count) {
#	warn "EOF on $which";
	$read_ports->remove($fh);
	$ports_left--;
        }
      else {
# 	warn "Read $count bytes from tsh $which: \n---\n$buffer\n---\n";
	$fromtsh{$which} .= $buffer;
	$did_something = 1;
        }
      }
    if (my $fh = $can_write->[0]) {
      my $count = syswrite($fh, $commands, length($commands));
      unless (defined $count) {
	die "\nsyswrite(tsh stdin) failed: $!";
        }
#     warn "Wrote $count bytes to tsh from: $commands";
      substr($commands, 0, $count) = '';
      $did_something = 1;
      unless (length($commands)) {
#	warn "no commands left to send";
	$write_ports->remove($fh);
	$ports_left--;
        }
      }
    if ($ports_left && !$did_something) {
      warn "\nselect() timed out, exiting.";
      last;
      }
    }

  $error += CompareReceived $stdout, SplitLines($fromtsh{'stdout'}), $error, 'stdout';
  $error += CompareReceived $stderr, SplitLines($fromtsh{'stderr'}), $error, 'stderr';
  close(TOTSH) || die "to-tsh exited $?";
  close(ERRTSH) || die "err-tsh exited $?";
  close(FROMTSH) || die "from-tsh exited $?";
  my $kid = waitpid($pid, WNOHANG);
  if ($kid != $pid) {
    print STDERR "\n" unless $error;
    if (kill 0, $pid) {
      print STDERR "* TSH process $pid is still running, trying to kill it.\n";
      if (kill 'TERM', $pid) {
	print STDERR "** Process killed.\n";
	$kid = waitpid($pid, 0);
	if ($kid != $pid) {
	  print STDERR "** Could not reap killed process: $!.\n";
	  if (kill 0, $pid) {
	    die "** Killed unreapable process still exists, giving up.\n";
	    }
	  }
	}
      else {
	print STDERR "** Kill failed: $!.\n";
	}
      }
    }
  return $error;
  }

sub SplitLines ($) {
  my $s = shift;
  my (@lines) = split($/, $s, -1);
  for my $line (@lines) { $line =~ s/[\012\015]+$//; }
  pop @lines if @lines && $lines[-1] eq '';
  return \@lines;
  }

sub WriteConfig ($$) {
  my $dir = shift;
  my $contents = shift;
  open my $fh, ">$dir/config.tsh" or die "Can't create $dir/config.tsh: $!";
  print $fh $contents or die "Can't write to $dir/config.tsh: $!";
  close $fh or die "Can't close $dir/config.tsh: $!";
  }

sub WriteIFile ($$$) {
  my $dir = shift;
  my $iname = shift;
  my $idata = shift;
  open my $fh, ">$dir/$iname" or die "Can't create $dir/$iname";
  print $fh $idata or die "Can't write to $dir/$iname";
  close $fh or die "Can't close $dir/$iname";
  }
