#!/opt/psh/bin/xpsh -f

# @(#)harness	1.8
#
# check to see if a given test is properly configured and return
# a '*' if not okay.
#
proc test_ok {req} {
	foreach x $req {
		global $x
		puts "test_ok: XXX: check on $x"
		if {![info exists $x]} {
			puts "Variable -$x- not set"
			puts "test_ok: variables are: [info vars]"
			return "*"
		}
	}
	puts "All items accounted for on $req"
	return
}


#
# Scan the current directory for valid tests.  Indicate whether the
# environment for the test is not yet configured.
#
proc scandir {} {
	global map
	sync_config
	foreach pstfile [glob -nocomplain *.pst] {
		lappend testfiles $pstfile
	}
	if {$testfiles == ""} {
		puts "No tests?
		return
	}
	set testfiles [lsort $testfiles]
	catch {
		foreach x $testfiles {
			if [catch "source $x" str] {
				puts "Test: $x: - Error in test: $str"
				puts "Probably means executable code outside of proc"
			}
			set missing($x) [t_req]
			set y $x
			if {[t_req] != 0} {
				set x "$x [t_info] *"
			} else {
				set x "$x [t_info]"
			}
			set list .connlb.list
			set map($y) [$list index end]
			$list insert end $x
		}
	}
	global configTable
	catch {exec rm -f $configTable(TCP_TRES)/target_info}
}


#
# "Sychronize current config" - this is a backward compatibility element
# for scripts written prior to psh 4.0.  Basically we copy each configTable
# value into a config variable of its own.  This should go away eventually.
#
proc sync_config {} {
	global configTable
	foreach i [array names configTable] {
		global $i
		set $i $configTable($i)
	}
}


#
# Launch the test corresponding to the Y coordinate of cursor.
#
proc startTest {w y} {
	global map stat
	set list .connlb.list

	# Get filename and title of the corresponding test
	set X [$list get [$list nearest $y]]
	if [regexp {^(.+) \*$} $X XXX q] {
		set X $q
	}
	set delim " ::: - "
	if ![regexp "^(.+)$delim" $X XXX title] {
		set title $X
	}
	set scr_name [lindex $X 0]
	set i $map($scr_name)
	catch {rename t_info ""}
	set err ""
	if [catch "source $scr_name" err] {
		puts "Error in test: $err"
		$list delete $i
		$list insert $i "$title${delim}Error in test: $err"
		return
	}
	if [catch {set title "$scr_name [t_info]"} err] {
		puts "Error in test: $err"
		$list delete $i
		$list insert $i "$title${delim}Error in test: $err"
		return
	}
	$list delete $i
	$list insert $i "$title${delim}In progress ..."

	set def_sh "/opt/psh/bin/psh"
	set err ""
	if [catch {set scr_f_id [open $scr_name]} err] {
		puts "Can't open $scr_name file for reading: $err"
		return
	}
	gets $scr_f_id line_n1
	catch {close $scr_f_id}
	if ![regexp "^#!(.+)$" $line_n1 XXX sh_of_scr] {
		set sh_of_scr $def_sh
	}
	if [regexp "/xpsh($)|( .+$)" $sh_of_scr] {
		# Launch xpsh scripts in the same process
		update
		source $scr_name
		catch t_run res
		if {$res != ""} {
			set stat "Failed: Error: $res"
		} else {
			set stat "Passed"
		}
		t_cleanup
		puts "Test: $scr_name: - $stat"
	} else {
		# Launch psh scripts
		execScript $scr_name watch .
	}

	$list delete $i
	$list insert $i "$title$delim$stat"
}


#
# - Sets the widgets specified in $args, together with their
#   children, into busy state and changes their cursor to
#   $newCursor.
# - Executes $script in a separate psh process and continues
#   to process events while waiting for it to finish.
# - Sets the given widgets into normal state again.
#
proc execScript {script newCursor args} {
	global scr_output
	set scr_output ""

	# Block the widgets and change their cursor
	foreach w $args {
		setBusy $w $newCursor
	}

	# Run a new separate psh process
	set pipe [open "| /opt/psh/bin/psh" r+]
	global configTable
	# Pass the config variables to the new psh process
	# This is a backward compatibility element
	foreach i [array names configTable] {
		puts $pipe "global $i; set $i $configTable($i)"
	}
	# Pass the config variables to the new psh process as
	# environment variables
	puts $pipe "global env"
	foreach i [array names configTable] {
		puts $pipe "set env($i) $configTable($i)"
	}
	puts $pipe "
		source $script
		catch t_run res
		if \{\$res != \"\"\} \{
			set scr_stat \"Failed: Error: \$res\"
		\} else \{
			set scr_stat \"Passed\"
		\}
		t_cleanup
		puts \"Test: $script: - \$scr_stat\"
		exit
	"
	flush $pipe

	fileevent $pipe readable "pipeHandler $pipe"
	tkwait variable scriptReady

	# Set the widgets into normal state
	foreach w $args {
		setNormal $w
	}
}


#
# Block $w widget. 
# - Change shape of cursor for the $w widget.
# - Remove binding tags for the $w widget.
#
proc setBusy {w newCursor} {
	global widgets
	if ![winfo exists $w] {return}
	catch {
		set widgets($w-cursor) [$w cget -cursor]
		$w config -cursor $newCursor
	}
	set widgets($w-bindtags) [bindtags $w]
	bindtags $w aNonExistentBindingTag
	foreach child [winfo children $w] {
		setBusy $child $newCursor
	}
}


#
# Unblock $w widget. 
# - Restore old shape of cursor for the $w widget.
# - Restore old binding tags for the $w widget.
#
proc setNormal w {
	global widgets
	if ![winfo exists $w] {return}
	catch { $w config -cursor $widgets($w-cursor) }
	catch { bindtags $w $widgets($w-bindtags) }
	foreach child [winfo children $w] {
		setNormal $child
	}
}


# Command pipeline event handler
# - Reads a character from the command pipeline and puts it to
#   stdout until end-of-file condition has occured on pipeline
#
proc pipeHandler {pipe} {
	global scriptReady stat scr_output
	catch {set char [read $pipe 1]}
	set scr_output $scr_output$char
	if [eof $pipe] {
		catch {close $pipe}
		set scriptReady 1
		set stat ""
		regexp "\nTest: .+\.pst: - (.+)\n$" $scr_output XXX stat
	} else {
		puts -nonewline $char; flush stdout
	}
}


proc update_disp {} {
	puts "update_disp: Update list of tests and how runnable they are"
	.connlb.list delete 0 end
	scandir
}


proc config_update {} {
	global configFile configTable
	if {[info exists configFile] && [file exists $configFile]} {
		puts "Read $configFile and update config variables"
		set cf [open $configFile r]
		while {[gets $cf configLine] > 0} {
			puts "Debug: $configLine"
			array set configTable [split $configLine]
		}
		close $cf
	}
	update_disp
}


proc save_config {} {
	global configFile configTable
	if [catch  {open $configFile w} cf] {
		if {$configFile == ""} {
			puts "No config file specified"
		} else {
			puts "Unable to write to $configFile"
		}
	} else {
		foreach i [array names configTable] {
			puts $cf "$i $configTable($i)"
		}
		close $cf
		puts "File $configFile written with current configuration"
	}
}


proc mkvar {win frame lab desc var} {
	global configTable
	frame $win.$frame
	label $win.$frame.l$lab -text $desc
	entry $win.$frame.e$lab -textvariable configTable($var) -relief sunken
	pack $win.$frame.l$lab -side left
	pack $win.$frame.e$lab -side right
	pack $win.$frame
	bind $win.$frame.e$lab <Return> "update_disp"
}


proc new_config_variable {} {
	global newVar configTable
	array set configTable [list $newVar set-me]
	mkvar .config f$newVar $newVar $newVar $newVar
	set newVar ""
	update_disp	;# May have changed runability of scripts...
}


proc configure {} {
	global configTable
	puts "Configure stuff..."
	toplevel .config
	foreach i [array names configTable] {
		puts "got var $i"
		mkvar .config f$i $i $i $i
	}
	frame .config.cnewvar
	label .config.cnewvar.vlabel -text "New variable"
	entry .config.cnewvar.vname -textvariable newVar -relief sunken
	bind .config.cnewvar.vname <Return> new_config_variable
	pack .config.cnewvar.vlabel -side left
	pack .config.cnewvar.vname -side left
	pack .config.cnewvar
	wm geometry .config +260+0
}


################################################################
frame .connlb

listbox .connlb.list -yscrollcommand [list .connlb.sy set] \
                     -xscrollcommand [list .connlb.sx set] \
                     -setgrid true -width 45
pack .connlb -fill both -expand true

frame .buttons
button .buttons.scan -text Update -command update_disp
pack .buttons.scan -side left
button .buttons.quit -text Quit -command exit
pack .buttons.quit -side left

button .buttons.configure -text "Mod Cfg" -command configure
pack .buttons.configure -side left
button .buttons.saveconfig -text "Save Cfg" -command save_config
pack .buttons.saveconfig -side left

label .buttons.flabel -text "Config File:" -width 10
entry .buttons.fname -textvariable configFile -relief sunken -width 18
bind .buttons.fname <Return> "config_update"
pack .buttons.flabel -side left
pack .buttons.fname -side left

pack .buttons -side left

scrollbar .connlb.sx -orient horizontal -command [list .connlb.list xview]
scrollbar .connlb.sy -orient vertical -command [list .connlb.list yview]

pack .connlb.sx -side bottom -fill x
pack .connlb.sy -side right -fill y
pack .connlb.list -side left -fill both -expand true

bind .connlb.list <Button-1> {startTest %W %y}

wm geometry . 50x12+0+0

if {[file exists "config"]} {
	;# An important convenience...
	;# When we start-up, if we find a filed named "config", assume
	;# that's the config file and read it.
	global configFile
	set configFile "config"
	config_update
} else {
	scandir
}
