aboutsummaryrefslogtreecommitdiff
path: root/contrib/bluegnu2.0.3/bluegnutkUtils.itcl
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/bluegnu2.0.3/bluegnutkUtils.itcl')
-rw-r--r--contrib/bluegnu2.0.3/bluegnutkUtils.itcl436
1 files changed, 436 insertions, 0 deletions
diff --git a/contrib/bluegnu2.0.3/bluegnutkUtils.itcl b/contrib/bluegnu2.0.3/bluegnutkUtils.itcl
new file mode 100644
index 0000000..0ed485e
--- /dev/null
+++ b/contrib/bluegnu2.0.3/bluegnutkUtils.itcl
@@ -0,0 +1,436 @@
+#
+#
+#
+
+# 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"
+ }
+ }
+ }
+ }
+}
generated by cgit v1.1 at 2024-11-15 14:07:39 +0000