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 }
