bluegnutkUtils.itcl [plain text]
#
#
#
# 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"
}
}
}
}
}