00001 # TKE - Advanced Programmer's Editor 00002 # Copyright (C) 2014-2019 Trevor Williams (phase1geo@gmail.com) 00003 # 00004 # This program is free software; you can redistribute it and/or modify 00005 # it under the terms of the GNU General Public License as published by 00006 # the Free Software Foundation; either version 2 of the License, or 00007 # (at your option) any later version. 00008 # 00009 # This program is distributed in the hope that it will be useful, 00010 # but WITHOUT ANY WARRANTY; without even the implied warranty of 00011 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00012 # GNU General Public License for more details. 00013 # 00014 # You should have received a copy of the GNU General Public License along 00015 # with this program; if not, write to the Free Software Foundation, Inc., 00016 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 00017 00018 ###################################################################### 00019 # Name: commit.tcl 00020 # Author: Trevor Williams (phase1geo@gmail.com) 00021 # Date: 9/12/2013 00022 # Brief: Contains namespace that runs a built-in self test. 00023 ###################################################################### 00024 00025 # msgcat::note In development mode -- selectable in the Advanced preferences section -- select "Tools / Run BIST" 00026 00027 # If the bist namespace already exists, delete it 00028 catch { namespace delete bist } 00029 00030 namespace eval bist { 00031 00032 variable testdir 00033 variable tests 00034 variable run_tests 00035 00036 array set data {} 00037 00038 # In case the UI is closed without running a regression... 00039 set data(done) 1 00040 set data(filter) "all" 00041 set data(runtype) "selected" 00042 00043 ###################################################################### 00044 # Populates the test list. 00045 proc refresh {args} { 00046 00047 variable data 00048 variable tests 00049 00050 # If the BIST window exists, we don't need to do anything 00051 if {![winfo exists .bistwin]} { 00052 return 00053 } 00054 00055 # Get the list of selected diagnostics in the table 00056 set selected [get_selections] 00057 00058 # Load all of the BIST files 00059 foreach bfile [glob -directory [file join $::tke_dir tests] *.tcl] { 00060 if {[catch { source $bfile } rc]} { 00061 puts $::errorInfo 00062 } 00063 } 00064 00065 # Gather the list of tests to run 00066 set tests [list] 00067 foreach ns [namespace children] { 00068 lappend tests {*}[info procs ${ns}::run_test*] 00069 } 00070 00071 # Organize the test items 00072 set i 0 00073 foreach test $tests { 00074 lassign [string map {{::} { }} $test] dummy category name 00075 lappend test_array($category) $name 00076 incr i 00077 } 00078 00079 # Clear the tablelist 00080 $data(widgets,tbl) delete 0 end 00081 00082 # Add the test items to the tablelist 00083 foreach category [lsort -dictionary [array names test_array]] { 00084 set node [$data(widgets,tbl) insertchild root end [list 1 $category 0 0 0 ""]] 00085 $data(widgets,tbl) rowconfigure $node -background grey 00086 $data(widgets,tbl) cellconfigure $node,selected -image $data(images,checked) 00087 foreach test [lsort -dictionary $test_array($category)] { 00088 set cmd [join [list bist $category $test] ::] 00089 set child [$data(widgets,tbl) insertchild $node end [list 1 $test 0 0 0 $cmd]] 00090 $data(widgets,tbl) cellconfigure $child,selected -image $data(images,checked) 00091 } 00092 } 00093 00094 # Collapse all tests 00095 $data(widgets,tbl) collapseall 00096 00097 # Sets the given selections 00098 set_selections $selected 00099 00100 } 00101 00102 ###################################################################### 00103 # Runs the built-in self test. 00104 proc run {} { 00105 00106 variable tests 00107 variable data 00108 variable run_tests 00109 00110 # Specify that the regression should run 00111 set data(run) 1 00112 set data(done) 0 00113 00114 # Initialize the filter 00115 set data(filter) "all" 00116 filter 00117 00118 # Initialize a few things first 00119 initialize 00120 00121 # Get the number of tests available to run 00122 set testslen [llength $run_tests] 00123 set err 0 00124 set pass 0 00125 set fail 0 00126 00127 # Make sure that the results tab is displayed. 00128 $data(widgets,nb) select 2 00129 00130 # Allow the BIST to dump output to the output text widget 00131 $data(widgets,output) configure -state normal 00132 $data(widgets,output) delete 1.0 end 00133 $data(widgets,output) configure -state disabled 00134 00135 # Initialize the pass and fail widgets 00136 $data(widgets,pass) configure -text 0 00137 $data(widgets,fail) configure -text 0 00138 00139 # Configure UI components 00140 $data(widgets,refresh) configure -state disabled 00141 $data(widgets,run) configure -text [msgcat::mc "Cancel"] -command [list bist::cancel] 00142 $data(widgets,runtype) configure -state disabled 00143 00144 update idletasks 00145 00146 output "---------------------------------------------\n" 00147 output [format "%s - %s\n\n" [msgcat::mc "RUNNING BIST"] [clock format [clock seconds]]] 00148 00149 set start_time [clock milliseconds] 00150 00151 if {$data(run_mode) eq "iter"} { 00152 $data(widgets,total) configure -text [$data(widgets,iters) get] 00153 set index 0 00154 for {set i 0} {$i < [$data(widgets,iters) get]} {incr i} { 00155 output [format {%s %4d: } [msgcat::mc "Iteration"] [expr $i + 1]] 00156 switch $data(iter_mode) { 00157 random { 00158 if {![run_test [expr int( rand() * $testslen )] pass fail err]} { 00159 break 00160 } 00161 } 00162 increment { 00163 if {![run_test $index pass fail err]} { 00164 break 00165 } 00166 set index [expr ($index + 1) % $testslen] 00167 } 00168 decrement { 00169 set index [expr ($index == 0) ? ($testslen - 1) : ($index - 1)] 00170 if {![run_test $index pass fail err]} { 00171 break 00172 } 00173 } 00174 } 00175 } 00176 } elseif {$data(run_mode) eq "loop"} { 00177 $data(widgets,total) configure -text [expr [$data(widgets,loops) get] * $testslen] 00178 for {set i 0} {$i < [$data(widgets,loops) get]} {incr i} { 00179 set tests [list] 00180 for {set j 0} {$j < $testslen} {incr j} { 00181 lappend tests $j 00182 } 00183 switch $data(loop_mode) { 00184 random { 00185 for {set j 0} {$j < $testslen} {incr j} { 00186 set rn [expr int( rand() * $testslen )] 00187 set val [lindex $tests $rn] 00188 lset tests $rn [lindex $tests $j] 00189 lset tests $j $val 00190 } 00191 } 00192 decrement { 00193 set tests [lreverse $tests] 00194 } 00195 } 00196 output [format "\n%s %d\n\n" [msgcat::mc "Loop"] [expr $i + 1]] 00197 for {set j 0} {$j < $testslen} {incr j} { 00198 output [format {%s %4d: } [msgcat::mc "Test"] [expr $j + 1]] 00199 if {![run_test [lindex $tests $j] pass fail err]} { 00200 break 00201 } 00202 } 00203 if {!$data(run)} { 00204 break 00205 } 00206 } 00207 } 00208 00209 set stop_time [clock milliseconds] 00210 00211 output [format "\n%s: %d, %s: %d\n\n" [msgcat::mc "PASSED"] $pass [msgcat::mc "FAILED"] $fail] 00212 output [format "%s: %s\n" [msgcat::mc "Runtime"] [runtime_string [expr $stop_time - $start_time]]] 00213 output "---------------------------------------------" 00214 00215 # Configure UI components 00216 $data(widgets,refresh) configure -state normal 00217 $data(widgets,run) configure -text [msgcat::mc "Run"] -command [list bist::run] 00218 00219 if {$fail == 0} { 00220 $data(widgets,runtype) configure -state disabled 00221 set data(runtype) "selected" 00222 } else { 00223 $data(widgets,runtype) configure -state normal 00224 } 00225 00226 # Wrap things up 00227 finish 00228 00229 } 00230 00231 ###################################################################### 00232 # Run the given test in the run_tests array. 00233 proc run_test {index ppass pfail perr} { 00234 00235 upvar $ppass pass 00236 upvar $pfail fail 00237 upvar $perr err 00238 00239 variable data 00240 variable run_tests 00241 00242 # Get the row and text to run 00243 lassign [lindex $run_tests $index] test row 00244 00245 # Get the row's parent 00246 set par [$data(widgets,tbl) parentkey $row] 00247 00248 # Increment the count cell for both the child and parent 00249 $data(widgets,tbl) cellconfigure $row,count -text [expr [$data(widgets,tbl) cellcget $row,count -text] + 1] 00250 $data(widgets,tbl) cellconfigure $par,count -text [expr [$data(widgets,tbl) cellcget $par,count -text] + 1] 00251 00252 output [format {%s %-40s... } [msgcat::mc "Running"] $test] 00253 00254 # Run the diagnostic and track the pass/fail status in the table 00255 if {[catch { $test } rc]} { 00256 incr fail 00257 output [format " %s (%s)\n" [msgcat::mc "FAILED"] $rc] failed 00258 logger::log $::errorInfo 00259 $data(widgets,fail) configure -text $fail 00260 $data(widgets,tbl) cellconfigure $row,fail -text [expr [$data(widgets,tbl) cellcget $row,fail -text] + 1] 00261 $data(widgets,tbl) cellconfigure $par,fail -text [expr [$data(widgets,tbl) cellcget $par,fail -text] + 1] 00262 } else { 00263 incr pass 00264 output [format " %s\n" [msgcat::mc "PASSED"]] passed 00265 $data(widgets,pass) configure -text $pass 00266 $data(widgets,tbl) cellconfigure $row,pass -text [expr [$data(widgets,tbl) cellcget $row,pass -text] + 1] 00267 $data(widgets,tbl) cellconfigure $par,pass -text [expr [$data(widgets,tbl) cellcget $par,pass -text] + 1] 00268 } 00269 00270 # Allow any user events to be handled 00271 update 00272 00273 # Specify if we should continue to run 00274 return $data(run) 00275 00276 } 00277 00278 ###################################################################### 00279 # Returns the runtime string. 00280 proc runtime_string {ms} { 00281 00282 set hours [expr $ms / 3600000] 00283 set minutes [expr ($ms - ($hours * 3600000)) / 60000] 00284 set seconds [expr ($ms - ($hours * 3600000) - ($minutes * 60000)) / 1000.0] 00285 00286 return [format "%d %s, %d %s, %g %s" $hours [msgcat::mc "hours"] $minutes [msgcat::mc "minutes"] $seconds [msgcat::mc "seconds"]] 00287 00288 } 00289 00290 ###################################################################### 00291 # Displays the given output to the BIST output widget. 00292 proc output {msg {tag ""}} { 00293 00294 variable data 00295 00296 $data(widgets,output) configure -state normal 00297 if {$tag ne ""} { 00298 $data(widgets,output) tag add $tag "end-1c linestart" end 00299 } 00300 $data(widgets,output) insert end $msg $tag 00301 $data(widgets,output) configure -state disabled 00302 00303 $data(widgets,output) see insert 00304 00305 } 00306 00307 ###################################################################### 00308 # Cancel the BIST diagnostic. 00309 proc cancel {} { 00310 00311 variable data 00312 00313 set data(run) 0 00314 00315 } 00316 00317 ###################################################################### 00318 # Initialize the test environment. 00319 proc initialize {} { 00320 00321 variable testdir 00322 variable data 00323 variable run_tests 00324 00325 # Create the test directory pathname 00326 set testdir [file join $::tke_home bist] 00327 00328 # Delete the test directory if it still exists 00329 file delete -force $testdir 00330 00331 # Create the test directory 00332 file mkdir $testdir 00333 00334 # Add files to the test directory 00335 for {set i 0} {$i < 5} {incr i} { 00336 if {![catch { open [file join $testdir test$i.txt] w} rc]} { 00337 puts $rc "This is test $i" 00338 close $rc 00339 } 00340 } 00341 00342 # Get the list of tests to run 00343 set run_tests [list] 00344 for {set i 0} {$i < [$data(widgets,tbl) size]} {incr i} { 00345 if {[$data(widgets,tbl) cellcget $i,selected -text]} { 00346 if {[set test [$data(widgets,tbl) cellcget $i,test -text]] ne ""} { 00347 lappend run_tests [list $test $i] 00348 } 00349 } 00350 } 00351 00352 # If we are only supposed to rerun failures, adjust the list 00353 if {$data(runtype) eq "failed"} { 00354 set failed_tests [list] 00355 foreach {startpos endpos} [$data(widgets,output) tag ranges failed] { 00356 if {[regexp [format {%s\s+(\S+)\s*\.\.\.} [msgcat::mc "Running"]] [$data(widgets,output) get $startpos $endpos] -> test]} { 00357 lappend failed_tests [list $test [lindex [lsearch -index 0 -inline $run_tests $test] 1]] 00358 } 00359 } 00360 set run_tests $failed_tests 00361 } 00362 00363 } 00364 00365 ###################################################################### 00366 # Wraps up the run. 00367 proc finish {} { 00368 00369 variable testdir 00370 variable data 00371 00372 # Delete the temporary test directory 00373 file delete -force $testdir 00374 00375 # Save the run settings 00376 save_options 00377 00378 # Specify that we are done 00379 set data(done) 1 00380 00381 } 00382 00383 ###################################################################### 00384 # GUI WINDOW CODE BELOW 00385 ###################################################################### 00386 00387 ###################################################################### 00388 # Create the BIST UI. 00389 proc create {} { 00390 00391 variable data 00392 00393 # If the BIST window already exists, do nothing 00394 if {[winfo exists .bistwin]} { 00395 return 00396 } 00397 00398 # Create images 00399 set data(images,unchecked) [image create photo -file [file join $::tke_dir lib images unchecked.gif]] 00400 set data(images,checked) [image create photo -file [file join $::tke_dir lib images checked.gif]] 00401 00402 # Create the window 00403 toplevel .bistwin 00404 wm title .bistwin [msgcat::mc "Built-In Self Test"] 00405 00406 # Create the main notebook 00407 set data(widgets,nb) [ttk::notebook .bistwin.nb] 00408 00409 # Add the regression setup frame 00410 .bistwin.nb add [set sf [ttk::frame .bistwin.nb.sf]] -text [msgcat::mc "Setup"] 00411 00412 ttk::frame $sf.tf 00413 set data(widgets,tbl) [tablelist::tablelist $sf.tf.tl -columns [list 0 {} 0 [msgcat::mc "Name"] 0 [msgcat::mc "Run Count"] 0 [msgcat::mc "Pass Count"] 0 [msgcat::mc "Fail Count"] 0 {}] \ 00414 -treecolumn 1 -exportselection 0 -stretch all \ 00415 -borderwidth 0 -highlightthickness 0 \ 00416 -selectbackground blue -selectforeground white \ 00417 -xscrollcommand [list $sf.tf.hb set] -yscrollcommand [list $sf.tf.vb set]] 00418 scroller::scroller $sf.tf.hb -orient horizontal -background white -foreground black -command [list $sf.tf.tl xview] 00419 scroller::scroller $sf.tf.vb -orient vertical -background white -foreground black -command [list $sf.tf.tl yview] 00420 00421 $sf.tf.tl columnconfigure 0 -name selected -editable 0 -resizable 0 -editwindow checkbutton \ 00422 -formatcommand [list bist::format_cell] -labelimage $data(images,unchecked) -labelcommand [list bist::label_clicked] 00423 $sf.tf.tl columnconfigure 1 -name name -editable 0 -resizable 0 -formatcommand [list bist::format_cell] 00424 $sf.tf.tl columnconfigure 2 -name count -editable 0 -resizable 0 00425 $sf.tf.tl columnconfigure 3 -name pass -editable 0 -resizable 0 00426 $sf.tf.tl columnconfigure 4 -name fail -editable 0 -resizable 0 00427 $sf.tf.tl columnconfigure 5 -name test -hide 1 00428 00429 bind [$data(widgets,tbl) bodytag] <Button-$::right_click> [list bist::handle_right_click %W %x %y %X %Y] 00430 00431 grid rowconfigure $sf.tf 0 -weight 1 00432 grid columnconfigure $sf.tf 0 -weight 1 00433 grid $sf.tf.tl -row 0 -column 0 -sticky news 00434 grid $sf.tf.vb -row 0 -column 1 -sticky ns 00435 grid $sf.tf.hb -row 1 -column 0 -sticky ew 00436 00437 pack $sf.tf -fill both -expand yes 00438 00439 # Add the options frame 00440 .bistwin.nb add [set of [ttk::frame .bistwin.nb.of]] -text [msgcat::mc "Options"] 00441 00442 ttk::radiobutton $of.lrb -text [msgcat::mc "Run loops"] -variable bist::data(run_mode) -value "loop" -command { 00443 bist::set_state .bistwin.nb.of.if disabled 00444 bist::set_state .bistwin.nb.of.lf normal 00445 } 00446 00447 ttk::frame $of.lf 00448 ttk::label $of.lf.lcl -text [format "%s: " [msgcat::mc "Loop count"]] 00449 set data(widgets,loops) [ttk::spinbox $of.lf.lcsb -from 1 -to 1000 -increment 1.0] 00450 ttk::label $of.lf.ltl -text [format "%s: " [msgcat::mc "Loop type"]] 00451 ttk::menubutton $of.lf.ltmb -menu [menu .bistwin.ltPopup -tearoff 0] 00452 00453 grid rowconfigure $of.lf 5 -weight 1 00454 grid columnconfigure $of.lf 0 -minsize 20 00455 grid columnconfigure $of.lf 1 -minsize 150 00456 grid columnconfigure $of.lf 3 -weight 1 00457 grid $of.lf.lcl -row 0 -column 1 -sticky news -padx 2 -pady 2 00458 grid $of.lf.lcsb -row 0 -column 2 -sticky news -padx 2 -pady 2 00459 grid $of.lf.ltl -row 1 -column 1 -sticky news -padx 2 -pady 2 00460 grid $of.lf.ltmb -row 1 -column 2 -sticky news -padx 2 -pady 2 00461 00462 ttk::radiobutton $of.irb -text [msgcat::mc "Run iterations"] -variable bist::data(run_mode) -value "iter" -command { 00463 bist::set_state .bistwin.nb.of.lf disabled 00464 bist::set_state .bistwin.nb.of.if normal 00465 } 00466 00467 ttk::frame $of.if 00468 ttk::label $of.if.icl -text [format "%s: " [msgcat::mc "Iteration count"]] 00469 set data(widgets,iters) [ttk::spinbox $of.if.icsb -from 1 -to 1000 -increment 1.0] 00470 ttk::label $of.if.itl -text [format "%s: " [msgcat::mc "Selection method"]] 00471 ttk::menubutton $of.if.itmb -menu [menu .bistwin.itPopup -tearoff 0] 00472 00473 grid rowconfigure $of.if 5 -weight 1 00474 grid columnconfigure $of.if 0 -minsize 20 00475 grid columnconfigure $of.if 1 -minsize 150 00476 grid columnconfigure $of.if 3 -weight 1 00477 grid $of.if.icl -row 0 -column 1 -sticky news -padx 2 -pady 2 00478 grid $of.if.icsb -row 0 -column 2 -sticky news -padx 2 -pady 2 00479 grid $of.if.itl -row 1 -column 1 -sticky news -padx 2 -pady 2 00480 grid $of.if.itmb -row 1 -column 2 -sticky news -padx 2 -pady 2 00481 00482 pack $of.lrb -fill x -padx 2 -pady 2 00483 pack $of.lf -fill x -padx 2 -pady 2 00484 pack $of.irb -fill x -padx 2 -pady 2 00485 pack $of.if -fill x -padx 2 -pady 2 00486 00487 # Create loop mode menu 00488 foreach {val lbl} [list \ 00489 "random" [msgcat::mc "Random"] \ 00490 "increment" [msgcat::mc "Incrementing order"] \ 00491 "decrement" [msgcat::mc "Decrementing order"] \ 00492 ] { 00493 set cmd [list bist::set_mode .bistwin.nb.of.lf.ltmb $lbl $val loop_mode] 00494 .bistwin.ltPopup add radiobutton -label $lbl -variable bist::data(loop_mode) -value $val -command $cmd 00495 } 00496 00497 # Create iteration mode menu 00498 foreach {val lbl} [list \ 00499 "random" [msgcat::mc "Random"] \ 00500 "increment" [msgcat::mc "Incrementing order"] \ 00501 "decrement" [msgcat::mc "Decrementing order"] \ 00502 ] { 00503 set cmd [list bist::set_mode .bistwin.nb.of.if.itmb $lbl $val iter_mode] 00504 .bistwin.itPopup add radiobutton -label $lbl -variable bist::data(iter_mode) -value $val -command $cmd 00505 } 00506 00507 # Initialize UI state 00508 set data(run_mode) "iter" 00509 set data(loop_mode) "random" 00510 set data(iter_mode) "random" 00511 $data(widgets,loops) set 1 00512 $of.lf.ltmb configure -text [msgcat::mc "Random"] 00513 $data(widgets,iters) set 50 00514 $of.if.itmb configure -text [msgcat::mc "Random"] 00515 set_state $of.lf disabled 00516 00517 # Add the results frame 00518 .bistwin.nb add [set rf [ttk::frame .bistwin.nb.rf]] -text [msgcat::mc "Results"] 00519 00520 ttk::labelframe $rf.of -text [msgcat::mc "Output"] 00521 set data(widgets,output) [text $rf.of.t -state disabled -wrap none \ 00522 -relief flat -borderwidth 0 -highlightthickness 0 \ 00523 -xscrollcommand [list $rf.of.hb set] \ 00524 -yscrollcommand [list $rf.of.vb set]] 00525 scroller::scroller $rf.of.hb -orient horizontal -background white -foreground black -command [list $rf.of.t xview] 00526 scroller::scroller $rf.of.vb -orient vertical -background white -foreground black -command [list $rf.of.t yview] 00527 00528 bind $rf.of.t <ButtonPress-$::right_click> [list bist::text_select_test %x %y] 00529 bind $rf.of.t <ButtonRelease-$::right_click> [list bist::text_jump_to_test %x %y] 00530 00531 grid rowconfigure $rf.of 0 -weight 1 00532 grid columnconfigure $rf.of 0 -weight 1 00533 grid $rf.of.t -row 0 -column 0 -sticky news 00534 grid $rf.of.vb -row 0 -column 1 -sticky ns 00535 grid $rf.of.hb -row 1 -column 0 -sticky ew 00536 00537 pack $rf.of -fill both -expand yes 00538 00539 # Add the main button frame 00540 ttk::frame .bistwin.bf 00541 set data(widgets,filter) [ttk::menubutton .bistwin.bf.filter -text [msgcat::mc "Filter"] -width 12 -menu .bistwin.filterPopup] 00542 set data(widgets,refresh) [ttk::button .bistwin.bf.refresh -style BButton -text [msgcat::mc "Refresh"] -width 7 -command [list bist::refresh]] 00543 set data(widgets,run) [ttk::button .bistwin.bf.run -style BButton -text [msgcat::mc "Run"] -width 7 -command [list bist::run]] 00544 set data(widgets,runtype) [ttk::menubutton .bistwin.bf.runtype -menu .bistwin.runPopup -state disabled] 00545 00546 # Pack the button frame 00547 ttk::label .bistwin.bf.l0 -text [format "%s: " [msgcat::mc "Total"]] 00548 set data(widgets,total) [ttk::label .bistwin.bf.tot -text "" -width 5] 00549 ttk::label .bistwin.bf.l1 -text [format "%s: " [msgcat::mc "Passed"]] 00550 set data(widgets,pass) [ttk::label .bistwin.bf.pass -text "" -width 5] 00551 ttk::label .bistwin.bf.l2 -text [format "%s: " [msgcat::mc "Failed"]] 00552 set data(widgets,fail) [ttk::label .bistwin.bf.fail -text "" -width 5] 00553 00554 pack .bistwin.bf.l0 -side left -padx 2 -pady 2 00555 pack .bistwin.bf.tot -side left -padx 2 -pady 2 00556 pack .bistwin.bf.l1 -side left -padx 2 -pady 2 00557 pack .bistwin.bf.pass -side left -padx 2 -pady 2 00558 pack .bistwin.bf.l2 -side left -padx 2 -pady 2 00559 pack .bistwin.bf.fail -side left -padx 2 -pady 2 00560 pack .bistwin.bf.runtype -side right -padx 2 -pady 2 00561 pack .bistwin.bf.run -side right -padx 2 -pady 2 00562 pack .bistwin.bf.refresh -side right -padx 2 -pady 2 00563 pack .bistwin.bf.filter -side right -padx 2 -pady 2 00564 00565 # Pack the main UI elements 00566 pack .bistwin.nb -fill both -expand yes 00567 pack .bistwin.bf -fill x 00568 00569 # Create output tags 00570 $data(widgets,output) tag configure passed -elide 0 00571 $data(widgets,output) tag configure failed -elide 0 00572 00573 # Handle a window destruction 00574 bind [$data(widgets,tbl) bodytag] <Button-1> [list bist::on_select %W %x %y] 00575 00576 # Create testlist menus 00577 menu .bistwin.filePopup -tearoff 0 00578 .bistwin.filePopup add command -label [msgcat::mc "New Test File"] -command [list bist::create_file] 00579 .bistwin.filePopup add command -label [msgcat::mc "New Test"] -command [list bist::create_test] 00580 .bistwin.filePopup add separator 00581 .bistwin.filePopup add command -label [msgcat::mc "Edit Test File"] -command [list bist::edit_file] 00582 00583 menu .bistwin.testPopup -tearoff 0 00584 .bistwin.testPopup add command -label [msgcat::mc "Edit Test"] -command [list bist::edit_test] 00585 00586 menu .bistwin.filterPopup -tearoff 0 00587 .bistwin.filterPopup add radiobutton -label [msgcat::mc "All"] -variable bist::data(filter) -value all -command [list bist::filter] 00588 .bistwin.filterPopup add separator 00589 .bistwin.filterPopup add radiobutton -label [msgcat::mc "Fail"] -variable bist::data(filter) -value fail -command [list bist::filter] 00590 .bistwin.filterPopup add radiobutton -label [msgcat::mc "Pass"] -variable bist::data(filter) -value pass -command [list bist::filter] 00591 00592 menu .bistwin.runPopup -tearoff 0 00593 .bistwin.runPopup add radiobutton -label [msgcat::mc "Selected"] -variable bist::data(runtype) -value selected 00594 .bistwin.runPopup add radiobutton -label [msgcat::mc "Failed"] -variable bist::data(runtype) -value failed 00595 00596 # Handle the window close event 00597 wm protocol .bistwin WM_DELETE_WINDOW [list bist::on_destroy] 00598 00599 # Populate the testlist 00600 refresh 00601 00602 # Load the saved options (if any) 00603 load_options 00604 00605 } 00606 00607 ###################################################################### 00608 # Parses the line which the user selected for test information and, if 00609 # found selects the text that matches the test pattern. 00610 proc text_select_test {x y} { 00611 00612 variable data 00613 00614 # Get the selected row 00615 set row [lindex [split [$data(widgets,output) index @$x,$y] .] 0] 00616 00617 # Clear the selection 00618 $data(widgets,output) tag remove sel 1.0 end 00619 00620 set pattern [format {%s \S+\s*\.\.\.} [msgcat::mc "Running"]] 00621 if {[set index [$data(widgets,output) search -count length -regexp -- $pattern $row.0 $row.end]] ne ""} { 00622 set start [expr {[string length [msgcat::mc "Running"]] + 1}] 00623 $data(widgets,output) tag add sel "$index+${start}c" "$index+[expr $length - 3]c" 00624 } 00625 00626 } 00627 00628 ###################################################################### 00629 # On right button release, gets the test file and test number to jump 00630 # to the given test. 00631 proc text_jump_to_test {x y} { 00632 00633 variable data 00634 00635 # Get our row 00636 set row [lindex [split [$data(widgets,output) index @$x,$y] .] 0] 00637 00638 # If there is selected text, compare its to ours 00639 if {([set endpos [lassign [$data(widgets,output) tag ranges sel] startpos]] ne "") && ([lindex [split $endpos .] 0] == $row)} { 00640 lassign [string map {:: { }} [$data(widgets,output) get $startpos $endpos]] dummy fname tname 00641 add_and_jump_to_test $fname $tname 00642 } 00643 00644 # Make sure that the selection is blown away no matter what 00645 $data(widgets,output) tag remove sel 1.0 end 00646 00647 } 00648 00649 ###################################################################### 00650 # Displays the UI window to enter a test file. 00651 proc create_file {} { 00652 00653 toplevel .bistwin.namewin 00654 wm title .bistwin.namewin [msgcat::mc "New Test Name"] 00655 wm transient .bistwin.namewin .bistwin 00656 wm resizable .bistwin.namewin 0 0 00657 00658 ttk::frame .bistwin.namewin.f 00659 ttk::label .bistwin.namewin.f.l -text [format "%s: " [msgcat::mc "Name"]] 00660 ttk::entry .bistwin.namewin.f.e -validate key -validatecommand [list bist::validate_file %P] 00661 00662 bind .bistwin.namewin.f.e <Return> [list .bistwin.namewin.bf.create invoke] 00663 00664 pack .bistwin.namewin.f.l -side left -padx 2 -pady 2 00665 pack .bistwin.namewin.f.e -side left -padx 2 -pady 2 -fill x 00666 00667 ttk::frame .bistwin.namewin.bf 00668 ttk::button .bistwin.namewin.bf.create -style BButton -text [msgcat::mc "Create"] -width 6 -command { 00669 bist::generate_file [.bistwin.namewin.f.e get] 00670 destroy .bistwin.namewin 00671 } -state disabled 00672 ttk::button .bistwin.namewin.bf.cancel -style BButton -text [msgcat::mc "Cancel"] -width 6 -command { 00673 destroy .bistwin.namewin 00674 } 00675 00676 pack .bistwin.namewin.bf.cancel -side right -padx 2 -pady 2 00677 pack .bistwin.namewin.bf.create -side right -padx 2 -pady 2 00678 00679 pack .bistwin.namewin.f -fill x 00680 pack .bistwin.namewin.bf -fill x 00681 00682 # Get the grab 00683 ::tk::SetFocusGrab .bistwin.namewin .bistwin.namewin.f.e 00684 00685 # Wait for the window to be destroyed 00686 tkwait window .bistwin.namewin 00687 00688 # Release the grab 00689 ::tk::RestoreFocusGrab .bistwin.namewin .bistwin.namewin.f.e 00690 00691 } 00692 00693 ###################################################################### 00694 # Validates the given filename and sets the UI state accordingly. 00695 proc validate_file {value} { 00696 00697 if {($value eq "") || [file exists [file join $::tke_dir tests $value.tcl]]} { 00698 .bistwin.namewin.bf.create configure -state disabled 00699 } else { 00700 .bistwin.namewin.bf.create configure -state normal 00701 } 00702 00703 return 1 00704 } 00705 00706 ###################################################################### 00707 # Adds the given test file to the editor. 00708 proc add_test_file {name} { 00709 00710 return [gui::add_file end [file join $::tke_dir tests $name.tcl] -sidebar 0 -remember 0 -savecommand [list bist::refresh]] 00711 00712 } 00713 00714 ###################################################################### 00715 # Generates a test file. 00716 proc generate_file {name} { 00717 00718 # Open a file for writing 00719 if {![catch { open [file join $::tke_dir tests $name.tcl] w } rc]} { 00720 00721 puts $rc "namespace eval $name {" 00722 puts $rc "" 00723 puts $rc " proc run_test1 {} {" 00724 puts $rc "" 00725 puts $rc " }" 00726 puts $rc "" 00727 puts $rc "}" 00728 00729 close $rc 00730 00731 } 00732 00733 # Add the file to the editor 00734 add_test_file $name 00735 00736 # Save the file 00737 gui::save_current 00738 00739 } 00740 00741 ###################################################################### 00742 # Create a new test 00743 proc create_test {} { 00744 00745 variable data 00746 00747 # Get the selected row 00748 set selected [$data(widgets,tbl) curselection] 00749 00750 # Get the test name 00751 set test [$data(widgets,tbl) cellcget $selected,name -text] 00752 00753 # Get the test name 00754 set row [lindex [$data(widgets,tbl) childkeys $selected] end] 00755 00756 # Get the new test name 00757 if {[regexp {run_test(\d+)} [$data(widgets,tbl) cellcget $row,name -text] -> num]} { 00758 set name "run_test[expr $num + 1]" 00759 } 00760 00761 # Add the file to the editor 00762 set tab [add_test_file $test] 00763 00764 # Get the text widget from the tab 00765 gui::get_info $tab tab txt 00766 00767 # Get the position of the second to last right curly bracket 00768 lassign [lrange [$txt tag ranges __curlyR] end-3 end-2] startpos endpos 00769 00770 # Insert the test 00771 $txt insert $endpos "\n\n proc $name {} {\n \n }" 00772 ::tk::TextSetCursor $txt $endpos+4c 00773 00774 # Save the file 00775 gui::save_current 00776 00777 } 00778 00779 ###################################################################### 00780 # Edit the currently selected test file. 00781 proc edit_file {} { 00782 00783 variable data 00784 00785 # Get the selected row 00786 set selected [$data(widgets,tbl) curselection] 00787 00788 # Get the diagnostic name 00789 set fname [$data(widgets,tbl) cellcget $selected,name -text] 00790 00791 # Add the file to the editor 00792 set tab [add_test_file $fname] 00793 00794 } 00795 00796 ###################################################################### 00797 # Place the test file into the editing buffer and place the cursor and 00798 # view at the start of the test. 00799 proc edit_test {} { 00800 00801 variable data 00802 00803 # Get the selected row 00804 set selected [$data(widgets,tbl) curselection] 00805 00806 # Get the test name 00807 set tname [$data(widgets,tbl) cellcget $selected,name -text] 00808 00809 # Get the diagnostic name 00810 set parent [$data(widgets,tbl) parentkey $selected] 00811 set fname [$data(widgets,tbl) cellcget $parent,name -text] 00812 00813 # Add the file and jump to the text 00814 add_and_jump_to_test $fname $tname 00815 00816 } 00817 00818 ###################################################################### 00819 # Adds the given file to the editor and jumps to the specified test. 00820 proc add_and_jump_to_test {fname tname} { 00821 00822 # Add the file to the editor 00823 set tab [add_test_file $fname] 00824 00825 # Get the text widget from the tab 00826 gui::get_info $tab tab txt 00827 00828 # Find the test in the file 00829 if {[set index [$txt search -regexp -- "proc\\s+$tname\\M" 1.0]] ne ""} { 00830 ::tk::TextSetCursor $txt $index 00831 } 00832 00833 } 00834 00835 ###################################################################### 00836 # Sets the current mode and update the UI state. 00837 proc set_mode {mb lbl val mode} { 00838 00839 variable data 00840 00841 # Update the menubutton 00842 $mb configure -text $lbl 00843 00844 # Update the mode value 00845 set data($mode) $val 00846 00847 } 00848 00849 ###################################################################### 00850 # Recursively sets the given widgets and all ancestors to the given state. 00851 proc set_state {w state} { 00852 00853 # Set the current state 00854 if {[catch { $w state [expr {($state eq "normal") ? "!disabled" : "disabled"}] } ]} { 00855 catch { $w configure -state $state } 00856 } 00857 00858 # Set the state of the child widgets 00859 foreach child [winfo children $w] { 00860 set_state $child $state 00861 } 00862 00863 } 00864 00865 ###################################################################### 00866 # Called when the tablelist widget is clicked on. 00867 proc on_select {W x y} { 00868 00869 variable data 00870 00871 lassign [tablelist::convEventFields $W $x $y] ::tablelist::W ::tablelist::x ::tablelist::y 00872 lassign [split [$data(widgets,tbl) containingcell $::tablelist::x $::tablelist::y] ,] row col 00873 00874 if {($row != -1) && ($col == 0)} { 00875 00876 # Set the checkbutton accordingly 00877 if {[$data(widgets,tbl) cellcget $row,selected -text]} { 00878 $data(widgets,tbl) cellconfigure $row,selected -text [set value 0] -image [set img $data(images,unchecked)] 00879 } else { 00880 $data(widgets,tbl) cellconfigure $row,selected -text [set value 1] -image [set img $data(images,checked)] 00881 } 00882 00883 # If the row is a category, make all of the children selections match the parent's value 00884 foreach child [$data(widgets,tbl) childkeys $row] { 00885 $data(widgets,tbl) cellconfigure $child,selected -text $value -image $img 00886 } 00887 00888 # Set the run type to selected and disable the runtype 00889 set data(runtype) "selected" 00890 $data(widgets,runtype) configure -state disabled 00891 00892 } 00893 00894 } 00895 00896 ###################################################################### 00897 # Handles a right-click on the table. 00898 proc handle_right_click {W x y X Y} { 00899 00900 variable data 00901 00902 lassign [tablelist::convEventFields $W $x $y] ::tablelist::W ::tablelist::x ::tablelist::y 00903 set row [$data(widgets,tbl) containing $::tablelist::y] 00904 00905 if {$row != -1} { 00906 00907 # Set the selection to the current row 00908 $data(widgets,tbl) selection clear 0 end 00909 $data(widgets,tbl) selection set $row 00910 00911 # Display the appropriate menu 00912 if {[$data(widgets,tbl) parentkey $row] eq "root"} { 00913 tk_popup .bistwin.filePopup $X $Y 00914 } else { 00915 tk_popup .bistwin.testPopup $X $Y 00916 } 00917 00918 } 00919 00920 } 00921 00922 ###################################################################### 00923 # Called when the BIST window is destroyed. Deletes images used by this 00924 # window. 00925 proc on_destroy {} { 00926 00927 variable data 00928 00929 catch { 00930 00931 # If the regression is running we cannot be quit 00932 if {!$data(done)} { 00933 00934 # Cause the regression to stop 00935 set data(run) 0 00936 00937 return 00938 00939 } 00940 00941 # Delete the images 00942 image delete $data(images,checked) $data(images,unchecked) 00943 00944 # Saves the current options 00945 save_options 00946 00947 } 00948 00949 # Delete the window 00950 destroy .bistwin 00951 00952 } 00953 00954 ###################################################################### 00955 # Handles displaying the given cell 00956 proc format_cell {value} { 00957 00958 variable data 00959 00960 lassign [$data(widgets,tbl) formatinfo] key row col 00961 00962 switch [$data(widgets,tbl) columncget $col -name] { 00963 "selected" { 00964 return "" 00965 } 00966 "name" { 00967 if {[$data(widgets,tbl) parentkey $key] eq "root"} { 00968 return [string totitle $value] 00969 } else { 00970 return $value 00971 } 00972 } 00973 } 00974 00975 return "" 00976 00977 } 00978 00979 ###################################################################### 00980 # Saves the current set of options to a file. 00981 proc save_options {} { 00982 00983 variable data 00984 00985 # Get the values to save into an array 00986 set options(run_mode) $data(run_mode) 00987 set options(loop_mode) $data(loop_mode) 00988 set options(iter_mode) $data(iter_mode) 00989 set options(loops) [$data(widgets,loops) get] 00990 set options(iters) [$data(widgets,iters) get] 00991 set options(selected) [get_selections] 00992 00993 # Write the options 00994 catch { tkedat::write [file join $::tke_home bist.tkedat] [array get options] 0 } 00995 00996 } 00997 00998 ###################################################################### 00999 # Load the options from the option file. 01000 proc load_options {} { 01001 01002 variable data 01003 01004 if {![catch { tkedat::read [file join $::tke_home bist.tkedat] 0 } rc]} { 01005 01006 array set options $rc 01007 01008 # Update the UI 01009 set data(run_mode) $options(run_mode) 01010 set data(loop_mode) $options(loop_mode) 01011 set data(iter_mode) $options(iter_mode) 01012 01013 $data(widgets,loops) set $options(loops) 01014 $data(widgets,iters) set $options(iters) 01015 01016 # Update UI state 01017 if {$data(run_mode) eq "loop"} { 01018 set_state .bistwin.nb.of.lf normal 01019 set_state .bistwin.nb.of.if disabled 01020 } else { 01021 set_state .bistwin.nb.of.lf disabled 01022 set_state .bistwin.nb.of.if normal 01023 } 01024 01025 # Update menubuttons 01026 for {set i 0} {$i <= [.bistwin.ltPopup index end]} {incr i} { 01027 if {[.bistwin.ltPopup entrycget $i -value] eq $options(loop_mode)} { 01028 .bistwin.nb.of.lf.ltmb configure -text [.bistwin.ltPopup entrycget $i -label] 01029 } 01030 } 01031 for {set i 0} {$i <= [.bistwin.itPopup index end]} {incr i} { 01032 if {[.bistwin.itPopup entrycget $i -value] eq $options(iter_mode)} { 01033 .bistwin.nb.of.if.itmb configure -text [.bistwin.itPopup entrycget $i -label] 01034 } 01035 } 01036 01037 # Set the selections 01038 set_selections $options(selected) 01039 01040 } 01041 01042 } 01043 01044 ###################################################################### 01045 # Returns a list containing the test names that are currently selected 01046 # in the selection table. 01047 proc get_selections {} { 01048 01049 variable data 01050 01051 set selected [list] 01052 01053 # Get the selection information 01054 for {set i 0} {$i < [$data(widgets,tbl) size]} {incr i} { 01055 if {([$data(widgets,tbl) parentkey $i] ne "root") && [$data(widgets,tbl) cellcget $i,selected -text]} { 01056 lappend selected [$data(widgets,tbl) cellcget $i,test -text] 01057 } 01058 } 01059 01060 return $selected 01061 01062 } 01063 01064 ###################################################################### 01065 # Sets the selections in the table based on the given list. 01066 proc set_selections {selected} { 01067 01068 variable data 01069 01070 set test_row -1 01071 set tsel_count 0 01072 01073 for {set i 0} {$i < [$data(widgets,tbl) size]} {incr i} { 01074 if {[$data(widgets,tbl) parentkey $i] eq "root"} { 01075 if {$test_row != -1} { 01076 set sel [expr {[llength [$data(widgets,tbl) childkeys $test_row]] == $sel_count}] 01077 $data(widgets,tbl) cellconfigure $test_row,selected -text $sel -image [expr {$sel ? $data(images,checked) : $data(images,unchecked)}] 01078 incr tsel_count $sel 01079 } 01080 set test_row $i 01081 set sel_count 0 01082 } else { 01083 set test [$data(widgets,tbl) cellcget $i,test -text] 01084 set sel [expr {[lsearch $selected $test] != -1}] 01085 incr sel_count $sel 01086 $data(widgets,tbl) cellconfigure $i,selected -text $sel -image [expr {$sel ? $data(images,checked) : $data(images,unchecked)}] 01087 } 01088 } 01089 01090 if {$sel_count != -1} { 01091 set sel [expr {[llength [$data(widgets,tbl) childkeys $test_row]] == $sel_count}] 01092 $data(widgets,tbl) cellconfigure $test_row,selected -text $sel -image [expr {$sel ? $data(images,checked) : $data(images,unchecked)}] 01093 incr tsel_count $sel 01094 } 01095 01096 if {[llength [$data(widgets,tbl) childkeys root]] == $tsel_count} { 01097 $data(widgets,tbl) columnconfigure selected -labelimage $data(images,checked) 01098 } else { 01099 $data(widgets,tbl) columnconfigure selected -labelimage $data(images,unchecked) 01100 } 01101 01102 } 01103 01104 ###################################################################### 01105 # Handles a left-click on the selected column image. 01106 proc label_clicked {tbl col} { 01107 01108 variable data 01109 01110 # Figure out the value of selected 01111 set sel [expr {[$data(widgets,tbl) columncget selected -labelimage] ne $data(images,checked)}] 01112 set img [expr {$sel ? $data(images,checked) : $data(images,unchecked)}] 01113 01114 # Change the label image 01115 $data(widgets,tbl) columnconfigure selected -labelimage $img 01116 01117 # Change the row images and values 01118 for {set i 0} {$i < [$data(widgets,tbl) size]} {incr i} { 01119 $data(widgets,tbl) cellconfigure $i,selected -text $sel -image $img 01120 } 01121 01122 } 01123 01124 ###################################################################### 01125 # Applies the current filter to the text field. 01126 proc filter {} { 01127 01128 variable data 01129 01130 switch $data(filter) { 01131 "all" { 01132 $data(widgets,output) tag configure passed -elide 0 01133 $data(widgets,output) tag configure failed -elide 0 01134 $data(widgets,filter) configure -text [format "%s: %s" [msgcat::mc "Filter"] [msgcat::mc "All"]] 01135 } 01136 "pass" { 01137 $data(widgets,output) tag configure passed -elide 0 01138 $data(widgets,output) tag configure failed -elide 1 01139 $data(widgets,filter) configure -text [format "%s: %s" [msgcat::mc "Filter"] [msgcat::mc "Pass"]] 01140 } 01141 "fail" { 01142 $data(widgets,output) tag configure passed -elide 1 01143 $data(widgets,output) tag configure failed -elide 0 01144 $data(widgets,filter) configure -text [format "%s: %s" [msgcat::mc "Filter"] [msgcat::mc "Fail"]] 01145 } 01146 } 01147 01148 } 01149 01150 }