Posted to tcl by de at Wed Feb 27 21:37:41 GMT 2013view raw

  1.  
  2. set options(-testapp) tcltest
  3. set options(-file) *.test
  4. set options(-notfile) ""
  5. set options(-tcltestdir) "../tests"
  6. set options(-testmain) "all.tcl"
  7. set options(-outfile) "singletests_out_[clock format [clock seconds] \
  8. -format "%Y-%m-%dT%T"].txt"
  9. set options(-overwriteoutfile) 0
  10. set options(-timeout) 10000
  11. set options(-progress) 100
  12.  
  13. proc readArgs {} {
  14. global argv
  15. global options
  16.  
  17. foreach {option arg} $argv {
  18. if {![info exists options($option)]} {
  19. puts stderr "Unknown option '$option'"
  20. exit 1
  21. }
  22. set options($option) $arg
  23. }
  24. }
  25.  
  26. proc getTestFiles {} {
  27. global options
  28.  
  29. set matchFileList [list]
  30. foreach pattern $options(-file) {
  31. set tmp [glob -nocomplain -tails \
  32. -directory $options(-tcltestdir) $pattern]
  33. set matchFileList [concat $matchFileList $tmp]
  34. }
  35. set matchFileList [lsort -unique $matchFileList]
  36. set skipFileList [list]
  37. foreach pattern $options(-notfile) {
  38. set tmp [glob -nocomplain -tails \
  39. -directory $options(-tcltestdir) $pattern]
  40. set skipFileList [concat $skipFileList $tmp]
  41. }
  42. set skipFileList [lsort -unique $skipFileList]
  43. set matchingFiles [list]
  44. foreach file $matchFileList {
  45. if {[lsearch -exact $skipFileList $file] == -1} {
  46. lappend matchingFiles $file
  47. }
  48. }
  49. if {[llength $matchingFiles] == 0} {
  50. puts stderr "No test files remain after applying match and\
  51. skip patterns!"
  52. exit 1
  53. }
  54. return $matchingFiles
  55. }
  56.  
  57. proc getTestNames {file} {
  58. global options
  59. global gettestnamesCmd
  60.  
  61. set cmd "$options(-testapp) $options(-tcltestdir)/$options(-testmain) \
  62. -verbose error -singleproc 1 "
  63.  
  64. set namesCmd "$gettestnamesCmd $options(-tcltestdir) $file"
  65. set rawtestnameslist [eval exec $namesCmd]
  66. set testnameslist [lindex [split $rawtestnameslist \n] end]
  67. foreach test $testnameslist {
  68. if {[info exists tmp($test)]} {
  69. puts "File '$file': not unique test name '$test'"
  70. }
  71. incr tmp($test)
  72. }
  73. return $testnameslist
  74. }
  75.  
  76. # From: http://wiki.tcl.tk/880
  77. proc isReadable { f } {
  78. global tcltestOutput
  79.  
  80. # The channel is readable; try to read it.
  81. set status [catch { gets $f line } result]
  82. if { $status != 0 } {
  83. # Error on the channel
  84. set ::DONE 2
  85. } elseif { $result >= 0 } {
  86. # Successfully read the channel
  87. append tcltestOutput $line\n
  88. } elseif { [eof $f] } {
  89. # End of file on the channel
  90. set ::DONE 1
  91. } elseif { [fblocked $f] } {
  92. # Read blocked. Just return
  93. } else {
  94. # Something else
  95. set ::DONE 3
  96. }
  97. }
  98.  
  99. proc testTimeout {} {
  100. global runningTest
  101. global testfile
  102. global test
  103. global summaryfd
  104. global options
  105.  
  106. puts $summaryfd "file $testfile test $test: Not finished after\
  107. $options(-timeout) milliseconds. Canceling the\
  108. test."
  109. set ::DONE 4
  110. }
  111.  
  112. proc testOneFile {file} {
  113. global options
  114. global gettestnamesCmd
  115. global testrun
  116. global timeoutID
  117. global testfile
  118. global test
  119. global summaryfd
  120. global tcltestOutput
  121.  
  122. set testfile $file
  123. puts $file
  124. set testcounter 0
  125. foreach test [getTestNames $file] {
  126. incr testcounter
  127. # Show, you're alive. Report progress.
  128. if {$testcounter >= $options(-progress)} {
  129. puts -nonewline "#"
  130. flush stdout
  131. set testcounter 0
  132. }
  133. set test $test
  134. set ::DONE 0
  135. set tcltestOutput ""
  136. set cmd "$options(-testapp) "
  137. append cmd " $options(-tcltestdir)/$options(-testmain) "
  138. append cmd " -file $file -match $test "
  139. append cmd " -verbose error "
  140. append cmd " -singleproc 1 "
  141. set runningTest [open "| $cmd"]
  142. fconfigure $runningTest -blocking false
  143. fileevent $runningTest readable [list isReadable $runningTest]
  144. set timeoutID [after $options(-timeout) testTimeout]
  145. vwait ::DONE
  146. after cancel $timeoutID
  147. set logmsg "\n\n****************\nfile $testfile test $test: "
  148. switch $::DONE {
  149. 1 {
  150. foreach line [split $tcltestOutput "\n"] {
  151. if {[string first $options(-testmain) $line] == 0} {
  152. # This sets the variables Total, Passed,
  153. # Skipped and Failed, as of tcltest 2.3.5.
  154. foreach {what nrOf} [lrange $line 1 end] {
  155. set $what $nrOf
  156. }
  157. if {$Failed != 0} {
  158. append logmsg "Test failed.\n$tcltestOutput"
  159. } else {
  160. set logmsg ""
  161. }
  162. }
  163. }
  164. }
  165. 2 {
  166. append logmsg "Error.\n$tcltestOutput"
  167. }
  168. 3 {
  169. append logmsg "Irregular read from subprocess\n$tcltestOutput"
  170. }
  171. 4 {
  172. # Test cancled after timeout. Already reported,
  173. # don't mess up log.
  174. set logmsg ""
  175. }
  176. default {
  177. # can't happen
  178. append logmsg "Reached 'can't happen' case in testOneFile."
  179. }
  180. }
  181. puts -nonewline $summaryfd $logmsg
  182. close $runningTest
  183. }
  184. puts ""
  185. }
  186.  
  187. proc init {} {
  188. global options
  189. global gettestnamesCmd
  190. global summaryfd
  191.  
  192. readArgs
  193. if {![file exists $options(-testapp)]} {
  194. puts stderr "No $::options(-testapp) app in the run dir. Aborting."
  195. exit 1
  196. }
  197. if {![string is boolean -strict $options(-overwriteoutfile)]} {
  198. puts stderr "The option -overwriteoutfile expects a boolean value.\
  199. Aborting."
  200. exit 1
  201. }
  202. if {![string is integer -strict $options(-timeout)]
  203. || $options(-timeout) <= 0} {
  204. puts string "The option -timeout expects a positive integer as value.\
  205. Aborting."
  206. exit 1
  207. }
  208. if {![string is integer -strict $options(-progress)]} {
  209. puts string "The options -progress expects a positive integer as\
  210. value. Aborting."
  211. exit 1
  212. }
  213. set options(-testapp) [file join [pwd] $options(-testapp)]
  214.  
  215. set gettestnamesCmd "$::options(-testapp) \
  216. [file join [file dirname [info script]] test-names.tcl]"
  217. if {[file exists $options(-outfile)] && !$options(-overwriteoutfile)} {
  218. puts stderr "Out file '$options(-outfile)' already exists\
  219. and -overwriteoutfile not true. Aborting."
  220. exit 1
  221. }
  222. set summaryfd [open $options(-outfile) w+]
  223. fconfigure $summaryfd -buffering line
  224. puts $summaryfd "Started\
  225. [clock format [clock seconds] -format "%Y-%m-%dT%T"]"
  226. puts $summaryfd "Test file pattern: $options(-file)\n"
  227. }
  228.  
  229. proc runEveryTestAlone {} {
  230. init
  231. foreach testfile [getTestFiles] {
  232. testOneFile $testfile
  233. }
  234. }
  235.  
  236. runEveryTestAlone
  237.