path: root/contrib/bluegnu2.0.3/bluegnutkUtils.itcl

#
#
#

# puts "MAIA TK Utilities"

set szView [file tail $env(CLEARCASE_ROOT)]
set szXipc $env(XIPCINSTANCE)

proc run {} {
    global env
    global szCommand wRun input wLog wRun
    global szView szXipc

    set env(CLEARCASE_ROOT) /view/$szView
    set env(XIPCINSTANCE) $szXipc

    set szCmd "xterm -sl 50000 -sb"
    if {[string length $szCommand] == 0} {
	set szCommand "$szCmd"
    } else {
	append szCmd " -e $szCommand"
    }
    if [catch {eval exec "$szCmd &"} input] {
	$wLog insert end $input
	bell
    } else {
	#fileevent $input readable log
	$wLog insert end "$env(PS1)$szCommand &\n"
	$wLog see end
	#$wRun config -text Stop -command stop
    }
}

proc log {} {
    global input wLog

    if [eof $input] {
	stop
    } else {
	gets $input szLine
	$wLog insert end "$szLine\n"
	$wLog see end
    }
}


proc stop {} {
    global input wRun

    catch {close $input}
    $wRun config -text "Run it" -command run
}

proc cmdUpdate {name1 name2 ops} {
    global szCommand szTarget szView szXipc \
	    szTestScript szTestcase szArguments
    global iSelect
    global lTestScripts lTestcaseIDs lArguments

    switch $name1 {
	szArguments {
	    set lArguments($iSelect) $szArguments
	}
	szTestcase {
	    set lTestcaseIDs($iSelect) $szTestcase
	}
    }

    set szCommand "bluegnu "
    if {[string compare $szTarget ""] != 0} {
	append szCommand "\"--target=$szTarget"
	if {[string compare $szView ""] != 0} {
	    append szCommand " view=$szView"
	}
	if {[string compare $szXipc ""] != 0} {
	    append szCommand " XIPCINSTANCE=$szXipc"
	}
	append szCommand "\" "
    }
    foreach i [lsort -integer [array names lTestScripts]] {
	# puts "test script index = $i"
	append szCommand "\"$lTestScripts($i)"
	if {[string compare $lTestcaseIDs($i) ""] !=0} {
	    append szCommand "\[$lTestcaseIDs($i)\]"
	}
	if {[string compare $lArguments($i) ""] != 0} {
	    #puts "szArguments: >$lArguments($i)<"
	    append szCommand "=$lArguments($i)"
	}
	append szCommand "\" "
    }
    #puts "szCommand: >$szCommand<"
}

proc setPWD {dir} {
    global szPWD wPWDmenu wPWDentry env
    #puts "setPWD $dir:"
    set szPWD $dir
    #puts "szPWD:: $szPWD"
    cd $szPWD
    catch {setTS "."}
    if {[string compare $szPWD "/"] != 0} {
	set szPWD "[exec /bin/sh -c pwd]/"
	regsub "/tmp_mnt" $szPWD "" szPWD
    }
    #puts "szPWD>: $szPWD"
    $wPWDentry insert [$wPWDentry index end] \
	    [string range $szPWD [$wPWDentry index end] end]
    #update idletasks
    $wPWDentry icursor end

    if {[$wPWDmenu index end] > 1} {
	$wPWDmenu delete 2 end
    }
    foreach F [lsort [glob *]] {
	if [file isdirectory $F] {
	    set szFile [file tail $F]
	    $wPWDmenu add command -label $szFile -command "setPWD $szFile"
	}
    }
}

proc setPWDoverwrite {name1 name2 ops} {
    global wPWDmenu env
    catch {upvar #0 $name1 szPWD} szErrMsg

    if {[file isdirectory $szPWD]} {
	trace vdelete szPWD w setPWDoverwrite
	setPWD $szPWD
	trace variable szPWD w setPWDoverwrite
    } else {
	set szDir {}
	foreach F [glob -nocomplain "${szPWD}*"] {
	    if [file isdirectory $F] {
		lappend szDir $F
	    }
	}
	# puts "szDir: >$szDir< [llength $szDir]"
	if {[llength $szDir] == 1} {
	    set szPWD $szDir
	    setPWD $szPWD
	} elseif {[llength $szDir] == 0} {
	    bell
	}
    }
}

proc checkDir {szDir} {
    regsub "^.*/home" $szDir "/home" szDir
    return $szDir
}

proc setTS {dir} {
    global szTS szTSdir wTSmenu wTSentry env wLR

    trace vdelete szTS w setTSoverwrite
    $wTSentry configure -state normal
    #puts "setTS $dir: [checkDir [exec /bin/sh -c pwd]]"
    if {[string compare $dir ".."] == 0} {
	# puts "##szTS: >$szTS<1"
	set szTStmp [file dirname $szTS]
	# puts "##szTS: >[set szTStmp [file dirname $szTS]]<2"
	$wTSentry delete 0 end
	# puts "##szTS: >$szTS<3"
	$wTSentry insert end "$szTStmp/"
    } elseif {[string compare $dir "."] == 0} {
	set szTStmp "."
	$wTSentry delete 0 end
	$wTSentry insert end "$szTStmp/"
	catch {listRemoved} szErrMsg
	#puts "err: $szErrMsg"
    } else {
	$wTSentry insert end "$dir/"
    }
    set szTmp [$wTSentry get]
    # puts "####### TS: >[set szTmp [$wTSentry get]]<"
    #puts "######szTS: >$szTS<"
    catch {insertTests $wLR}

#     update idletasks
#     $wTSentry icursor end

    # puts "TS menu index: [$wTSmenu index end]"
    if {[$wTSmenu index end] != "none"} {
	$wTSmenu delete 0 end
    }
    if {[string compare $szTmp "./"] != 0} {
	$wTSmenu add command -label .. \
		-command "setTS .."
    }
    foreach F [lsort [glob -nocomplain ${szTmp}*]] {
	if [file isdirectory $F] {
	    set szFile [file tail $F]
	    $wTSmenu add command -label $szFile \
		    -command "setTS $szFile"
	}
    }
    $wTSentry configure -state disabled
    trace variable szTS w setTSoverwrite
    # puts "TS menu end"
}

proc setEXPECT {dir} {
    global szExpect wEXPECTentry env
    # puts "Set env(EXPECT) to $dir"

    trace vdelete szExpect w setExpectOverwrite
    $wEXPECTentry configure -state normal
    $wEXPECTentry delete 0 end
    $wEXPECTentry insert end "$dir"
    set szExpect $dir
    $wEXPECTentry configure -state disabled
    trace variable szExpect w setExpectOverwrite
}

proc setTSoverwrite {name1 name2 ops} {
    global wTSmenu env
    catch {upvar #0 $name1 szTS} szErrMsg

    # puts "szTS >$szTS<"
    #setTS $szTS
}

proc setExpectOverwrite {name1 name2 ops} {
    #global wEmenu env
    catch {upvar #0 $name1 szExpect} szErrMsg
}

proc setExpect {name1 name2 ops} {
    global szExpect env

    if {[string length $szExpect] == 0} {
	catch {unset env(EXPECT)}
    } else {
	set env(EXPECT) $szExpect
    }
}

proc scrollSet {wScroll geoCmd offset size} {
    if {$offset != 0.0 || $size != 1.0} {
	eval $geoCmd; # make sure it is visible
	$wScroll set $offset $size
    } else {
	set manager [lindex $geoCmd 0]
	$manager forget $wScroll; # hide it
    }
}

proc scrolledListBox {w args} {
    frame $w -width 200
    grid rowconfigure $w 0 -weight 1
    grid columnconfigure $w 0 -weight 1
    listbox $w.list \
	    -xscrollcommand [list scrollSet $w.xscroll \
	    [list grid $w.xscroll -row 1 -column 0 -sticky we]] \
	    -yscrollcommand [list scrollSet $w.yscroll \
	    [list grid $w.yscroll -row 0 -column 1 -sticky ns]]
    eval {$w.list configure} $args
    scrollbar $w.xscroll -orient horizontal \
	    -command [list $w.list xview]
    scrollbar $w.yscroll -orient vertical \
	    -command [list $w.list yview]
    grid $w.list $w.yscroll -sticky news
    grid $w.xscroll -sticky news
    return $w.list
}

proc listTransferSelected {w wL} {
    global szTS wLR
    global lTestScripts lTestcaseIDs lArguments

    set i [lindex [$w curselection] 0]
    set szTest [$w get $i]
    set szTestScript [file join $szTS $szTest]
    # puts "selected: >$szTest<"
    set i [$wL index end]
    set lTestScripts($i) $szTestScript
    set lTestcaseIDs($i) ""
    set lArguments($i) [getArguments $szTestScript]
    # puts "set lArguments($i) $lArguments($i)"
    $wL insert end $szTestScript
    cmdUpdate lArguments {} u
}

proc listRemoved {} {
    global lTestScripts lTestcaseIDs lArguments
    global wLL szCommand

    if [catch {set jMax [$wLL index end]}] return
    for {set i $jMax} {$i > 0} {incr i -1} {
	catch {unset lTestScripts($i)}
	catch {unset lTestcaseIDs($i)}
	catch {unset lArguments($i)}
	$wLL delete $i
    }
    set szCommand ""
}

proc listTransferRemoved {w wL} {
    global lTestScripts lTestcaseIDs lArguments

    set jMax [$w index end]
    foreach i [lsort -integer -decreasing [$w curselection]] {
	# puts "i = $i; jMax = $jMax"
	if {$i + 1 < $jMax} {
	    for {set j $i} {$j < $jMax - 1} {incr j} {
		set k [expr $j + 1]
		# puts "j = $j; k = $k"
		set lTestScripts($j) $lTestScripts($k)
		set lTestcaseIDs($j) $lTestcaseIDs($k)
		set lArguments($j) $lArguments($k)
		unset lTestScripts($k)
		unset lTestcaseIDs($k)
		unset lArguments($k)
	    }
	} else {
	    unset lTestScripts($i)
	    unset lTestcaseIDs($i)
	    unset lArguments($i)
	}
	cmdUpdate lArguments {} u
	$w delete $i
    }
}

proc listTransferData {w} {
    global iSelect szArguments wArguments szTestcase wTestcase
    global lTestcaseIDs lArguments

    if {! [catch {set iSelect [lindex [$w curselection] 0]}]} {
	if {[llength iSelect] == 1} {
	    selection own -command [list lostSelection $w] $w
	    # trace vdelete szArguments w cmdUpdate
	    set szArguments $lArguments($iSelect)
	    $wArguments configure -state normal
	    # trace variable szArguments w cmdUpdate
	    # trace vdelete szTestcase w cmdUpdate
	    set szTestcase $lTestcaseIDs($iSelect)
	    $wTestcase configure -state normal
	    # trace variable szTestcase w cmdUpdate
	    cmdUpdate lArguments {} u
	}
    }
}

proc lostSelection {w} {
    global wArguments wTestcase
    global iSelect szArguments szTestcase

    set i [$w index active]
    # $w selection clear $i
    # trace vdelete szArguments w cmdUpdate
    # trace vdelete szTestcase w cmdUpdate
    # set szArguments ""
    # set szTestcase "" 
    # trace variable szArguments w cmdUpdate
    # trace variable szTestcase w cmdUpdate
    $wArguments configure -state disabled
    $wTestcase configure -state disabled
}

proc getArguments {ts} {
    if [file exists $ts] {
	set F [open $ts r]
	set bArg 0
	set szArgs ""
	while {[gets $F szLine] >= 0} {
	    switch -regexp $szLine {
		"Mandatory Arguments:" -
		"Optional Arguments:" {
		    set bArg 1
		    continue
		}
		{^# *$} {
		    set bArg 0
		    continue
		}
		{^processTestScriptArgs} {
		    break
		}
		default {
		    if {$bArg} {
			set bRepl [regsub {^# *} $szLine {} szArg]
			if {! $bRepl} {
			    set bRepl [regsub "^\[ \t ]*set *" \
				    $szLine {} szArg]
			    if {$bRepl} {
				regsub " " $szArg "=" szArg
				regsub -all {"} $szArg "" szArg
				regsub -all "\{" $szArg "" szArg
				regsub -all "\}" $szArg "" szArg
			    }
			}
			if {$bRepl} {
			    regsub { *; *#.*$} $szArg {} szArg
			    if {[string first " " $szArg] >= 0} {
				append szArgs "\{[string trim $szArg]\} "
			    } else {
				append szArgs "[string trim $szArg] "
			    }
			}
		    }
		}
	    }
	}
	close $F
	return [string trim $szArgs]
    }
    return ""
}

proc insertTests {w} {
    global szTS

    $w delete 0 end
    foreach F [lsort [glob -nocomplain ${szTS}/*]] {
	if {! [file isdirectory $F]} {
	    switch -regexp $F {
		{~$} -
		{[.]sql$} -
		{[.]err$} -
		{[.]log$} -
		{[.]out$} -
		{[.]txt$} -
		{tclIndex$} {
		    # Nothing to be done, will not be added to list
		}
		default {
		    set szFile [file tail $F]
		    $w insert end "$szFile"
		}
	    }
	}
    }
}