Posted to tcl by marc.ziegenhagen at Tue May 24 10:33:11 GMT 2011view raw

  1. package require Tk
  2. package require dde
  3.  
  4. set Program(name) $argv0
  5. set Program(callname) {}
  6. set Program(debugfile) [file rootname $Program(name)].log
  7. set Program(DDEservices) {}
  8. set Options(-DDE) {}
  9. set Options(-Call) {}
  10. set Options(-CallEntry) {test.tcl}
  11.  
  12. set Tick(begin) [clock clicks]
  13. set Tick(last) $Tick(begin)
  14.  
  15. proc Debug {msg} {
  16. set step [clock clicks]
  17. set diff [expr $step - $::Tick(begin)]
  18. set difflast [expr $step - $::Tick(last)]
  19. set ::Tick(last) $step
  20. set fd [open $::Program(debugfile) a+]
  21. set line [format "%8s %12s %8d %8d %s" [pid] $step $diff $difflast $msg]
  22. puts $fd $line
  23. puts $line
  24. close $fd
  25. }
  26.  
  27. proc Call {{prg {}} args} {
  28. global Program Options
  29. if {![string length $prg]} {
  30. set prg $Options(-CallEntry)
  31. }
  32. Debug "Call $prg $args"
  33. set name [GetUniqueName $prg]
  34. set Program(callname) $name
  35. set cmd "tclsh $prg [concat -DDE $name $args]"
  36. Debug "open |$cmd r"
  37. set Program(callfd) [open |$cmd r]
  38. fconfigure $Program(callfd) -blocking 0 -buffering line
  39. fileevent $Program(callfd) readable "Callback $Program(callfd)"
  40.  
  41. Debug "exec done"
  42. }
  43.  
  44. proc Callback {sock} {
  45. global Program
  46. #Debug "Callback $sock"
  47.  
  48. if {[gets $sock line] < 0} {
  49. Debug "$sock: EOF"
  50. fileevent $sock readable {}
  51. set Program(callfd) {}
  52. return
  53. }
  54. #Debug "Callback $sock: $line"
  55. }
  56.  
  57. proc SetUniqueName {{name {}}} {
  58. set serv [GetUniqueName $name]
  59. Debug "SetUniqueName: \[dde servername $serv]"
  60. dde servername $serv
  61. Debug "SetUniqueName: $serv"
  62. return $serv
  63. }
  64.  
  65. proc GetUniqueName {{name {}}} {
  66. global Program
  67. if {![string length $name]} {
  68. set name $Program(name)
  69. }
  70. Debug "GetUniqueName: $name"
  71. set i 2
  72. set serv $name
  73. set new $name-$i
  74. Debug "GetUniqueName: \[dde eval $name {dde servername}]"
  75. set err [catch {dde eval $name {dde servername}} ret]
  76. Debug "GetUniqueName: err=$err ret=$ret"
  77. while { $err == 0 } {
  78. Debug "GetUniqueName: \[dde eval $new {dde servername}]"
  79. set err [catch {dde eval $new {dde servername}} ret]
  80. Debug "GetUniqueName: err=$err ret=$ret"
  81. set serv $new
  82. incr i
  83. set new $name-$i
  84. }
  85. Debug "GetUniqueName: $serv"
  86. return $serv
  87. }
  88.  
  89. proc GetDDEservices {{topic {TclEval}} args} {
  90. global Program
  91. Debug "GetDDEServices: \[dde services $topic {}]"
  92. set Program(DDEservices) [dde services $topic {}]
  93. Debug "GetDDEServices: $Program(DDEservices)"
  94. }
  95.  
  96. proc CreateGui {w} {
  97. if {$w != "."} {
  98. set w ${w}.
  99. }
  100. pack [frame .f1] -side top
  101. pack [label .f1.lpn -text Programmname] -side left
  102. pack [label .f1.epn -textvariable Program(name)] -side left
  103. pack [frame .f2] -side top
  104. pack [label .f2.lcn -text Callname] -side left
  105. pack [label .f2.ecn -textvariable Program(callname)] -side left
  106. pack [frame .f3] -side top
  107. pack [label .f3.lce -text "Call Programm"] -side left
  108. pack [entry .f3.ece -textvariable Options(-CallEntry)] -side left
  109. pack [button .f3.bca -text "Call" -command Call]
  110. pack [frame .f4] -side top
  111. pack [label .f4.lde -text "DDE Services"] -side left
  112. pack [label .f4.ede -textvariable Program(DDEservices)] -side left
  113. pack [button .f4.bge -text "Get" -command GetDDEservices]
  114. pack [button .bu -text "Ende" -command exit]
  115. update
  116. }
  117.  
  118. # Main
  119.  
  120. Debug "argv=$argv argc=$argc"
  121. if {$argc > 0} {
  122. catch {array set Options $argv}
  123. }
  124.  
  125. CreateGui .
  126.  
  127. GetDDEservices
  128.  
  129. if {[string length $Options(-DDE)]} {
  130. Debug "SetUniqueName $Options(-DDE)"
  131. set Program(name) [SetUniqueName $Options(-DDE)]
  132. } else {
  133. SetUniqueName
  134. }
  135.  
  136. GetDDEservices
  137.  
  138. if {[string length $Options(-Call)]} {
  139. Debug "Call $Options(-Call) -Test 1"
  140. Call $Options(-Call) -Test 1
  141. }
  142.  
  143. GetDDEservices
  144.  
  145. vwait forever