#!/usr/local/bin/perl

require 'getopts.pl';
if (!&Getopts('qv')) {
    print "\nsomething seems wrong with the options you provided .....\n\n",
          "Usage: $0 [OPTIONS] testfile1 [testfile2 ... ]\n\n",
          "       -q .... quiet (print less messages)\n",
          "       -v .... verbose mode\n",
	  "\n";
    exit -1;
}

$wafe   = "wafe";
if ($#ARGV == -1) {
    @scripts = (
	    '1-of-m.tcl',
	    'barplot.tcl',
	    'barplot2.tcl',
	    'backup-admin',
	    'pix_tst',
	    'list_tst',
	    'layout.tcl',
	    'm-cal',
	    'm-caption',
	    'm-combo',
	    'm-compound',
	    'm-demo',
	    'm-layout',
	    'm-pix_tst'
		);
    $path = '../';
} else {
    @scripts = @ARGV;
    $path = '';
}

$TCL_DO_PROCS = <<'_';
append FILESEARCHPATH :../%N
proc _DO {cmd} {
  uplevel \#0 "eval {$cmd}"
  addWorkProc {sync topLevel false; return 1}
}

proc _REPORT {widget} {
  xflush topLevel
  addTimeOut 200 "puts w=[window $widget];puts DONE;flush stdout"
}
_

sub do_in_wafe {
    local($cmd,$widget) = @_;
    print S1 "_DO {$cmd}\n";
    print S1 "_REPORT $widget\n" if $widget;
    while (<S1>) {
	print "got <$_>\n" if $opt_v;
	$window = $1 if m/^w=(\d+)$/;
	last if /^DONE/; 
    }
}

sub compare_results {
    local($script_name,$window) = @_;
    # print "window = $window\n";
    $xwd_new = "$script_name.gif.log";
    $xwd_ok  = "$script_name.gif.ok";
    system("xgrabsc -xwd -nobell -id $window "
	   ."| (xwdtopnm|ppmtogif >$xwd_new 2>/dev/null)");
    if (-r $xwd_ok) {
	if (system("cmp $xwd_new $xwd_ok")) {
	    system("xv $xwd_ok&");
	    print "image for $script_name is different;\n"
		."if corrected use..\n"
		."   mv -f $xwd_new $xwd_ok\n";
	    exit;
	} else {
	    print "correct: $script_name\n";
	    unlink "$xwd_new";
	    }
    } else {
	system("mv $xwd_new $xwd_ok");
	print "new: $script_name\n";
    }
}

sub fork_and_start {
    local($script) = @_;
    local($script_name) = ($script =~ m|([^/]+)$|);

    die "socketpair unsuccessful: $!!\n" unless socketpair(S0,S1,1,1,0);
    if ($pid=fork) {
	# we are in the parent process; 
	# set the connection to the child to line buffered and ...

	# first, check whether there is a cmd file....
	local($cmds,$window);
	if (-r "$script_name.cmds") {
	    undef $/;
	    open(C, "<$script_name.cmds") && ($cmds = <C>) && close(C);
	    $/ = "\n";
	}
	# print "<<$cmds>>\n";

	# set the output to wafe lin buffered
	select(S1); $| = 1;
	select(STDOUT);

	# ... define the TCL procedures and source the script
	print S1 $TCL_DO_PROCS;
	&do_in_wafe("source $script", 'topLevel');
	&compare_results($script_name,$window);

	local($cmd_count) = 0;
	foreach (split(/\n/,$cmds)) {
	    next if /^\#/;
	    if (/^(\S+):\s(.*)$/) {
		($widget,$cmd) = ($1,$2);
		$cmd_count++;
		&do_in_wafe($cmd, $widget);
		&compare_results($script_name."-$cmd_count",$window);
	    } elsif (/^\w/) {
		print S1 $_,"\n";
	    }
	}
	print S1 "quit\n";
    } elsif (defined $pid) {
	# this is the forked process, 
	# so, connect i/o channels 
	open(F,"<$script") && ($first_line = <F>) && close F;
	$wafe = "../../$1" if $first_line =~ /(wafe|mofe)/;
	open(STDOUT, ">&S0");
	open(STDIN, ">&S0");
	close(S0);
	select(STDOUT); $| = 1;
	# print STDERR  "$wafe  --d --n -geometry +0+0";
	exec "$wafe --d --n -geometry +0+0";
    } else {
	# something went wrong during the fork 
	die "fork error: $!\n";
    }
}

foreach $script (@scripts) {
    &fork_and_start($path.$script);
}




