Posted to tcl by osprey at Fri Jul 02 10:55:19 GMT 2010view raw

  1. package require Tk
  2.  
  3. #---------------
  4. # http://wiki.tcl.tk/3958
  5. # atexit - exit hook
  6. namespace eval AtExit {
  7. variable atExitScripts [list]
  8.  
  9. proc atExit script {
  10. variable atExitScripts
  11. lappend atExitScripts \
  12. [uplevel 1 [list namespace code $script]]
  13. }
  14.  
  15. namespace export atExit
  16. }
  17.  
  18. rename exit AtExit::ExitOrig
  19. proc exit {{code 0}} {
  20. variable AtExit::atExitScripts
  21. set n [llength $atExitScripts]
  22. while {$n} {
  23. catch [lindex $atExitScripts [incr n -1]]
  24. }
  25. rename exit {}
  26. rename AtExit::ExitOrig exit
  27. namespace delete AtExit
  28. exit $code
  29. }
  30.  
  31. namespace import AtExit::atExit
  32.  
  33. #---------------
  34. # If the <prog>ram successfully starts, its STDOUT and STDERR is dispatched
  35. # line by line to the <readHandler> (via bgExecGenericHandler) as last arg.
  36. # <pCount> holds the number of processes called this way. If a <timeout> is
  37. # specified (as msecs), the process pipeline will be automatically closed after
  38. # that duration. If specified, and a timeout occurs, <toExit> is called with
  39. # the PIDs of the processes right before closing the process pipeline.
  40. # Returns the handle of the process-pipeline.
  41. #
  42. # http://wiki.tcl.tk/12704
  43. proc bgExec {prog readHandler pCount {timeout 0} {toExit ""}} {
  44. upvar #0 $pCount myCount
  45. set myCount [expr {[info exists myCount]?[incr myCount]:1}]
  46. set p [expr {[lindex [lsort -dict [list 8.4.7 [info patchlevel]]] 0] == "8.4.7"?"| $prog 2>@1":"| $prog 2>@stdout"}]
  47. set pH [open $p r]
  48. fconfigure $pH -blocking 0; # -buffering line (does it really matter?!)
  49. set tID [expr {$timeout?[after $timeout [list bgExecTimeout $pH $pCount $toExit]]:{}}]
  50. fileevent $pH readable [list bgExecGenericHandler $pH $pCount $readHandler $tID]
  51. atExit [list close $pH]
  52. return $pH
  53. }
  54.  
  55. proc bgExecGenericHandler {chan pCount readHandler tID} {
  56. global errorCode
  57. upvar #0 $pCount myCount
  58. if {[eof $chan]} {
  59. after cancel $tID; # empty tID is ignored
  60. catch {close $chan}; # automatically deregisters the fileevent handler
  61. # (see Practical Programming in Tcl an Tk, page 229)
  62. incr myCount -1
  63. } elseif {[gets $chan line] != -1} {
  64. # we are not blocked (manpage gets, Practical... page.233)
  65. lappend readHandler $line
  66. if {[catch {uplevel $readHandler}]} {
  67. # user-readHandler ended with error -> terminate the processing
  68. after cancel $tID
  69. catch {close $chan}
  70. incr myCount -1
  71. }
  72. }
  73. }
  74.  
  75. proc bgExecTimeout {chan pCount toExit} {
  76. upvar #0 $pCount myCount
  77. if {[string length $toExit]} {
  78. catch {uplevel [list $toExit [pid $chan]]}
  79. }
  80. catch {close $chan}
  81. incr myCount -1
  82. }
  83.  
  84.  
  85. wm protocol . WM_DELETE_WINDOW {
  86. if {[tk_messageBox -parent . -title "Close?" -icon question \
  87. -type yesno -default no -message "Do You want to quit"] == yes} {
  88. exit
  89. }
  90. }
  91.  
  92. proc logger {output} {
  93. puts $logger
  94. }
  95.  
  96. # main
  97.  
  98. set h1 [bgExec "notepad.exe" logger pCount]
  99. # wait for finish
  100. vwait pCount
  101.