1# -*- tcl -*- 2# Dialog - Dialog Demon (Server, or Client) 3# Copyright (c) 2004, Andreas Kupries <andreas_kupries@users.sourceforge.net> 4 5puts "- dialog (coserv-based)" 6 7# ### ### ### ######### ######### ######### 8## Commands on top of a plain comm server. 9## Assumes that the comm server environment 10## is present. Provides set up and execution 11## of a fixed linear dialog, done from the 12# perspective of a server application. 13 14# ### ### ### ######### ######### ######### 15## Load "comm" into the master. 16 17namespace eval ::dialog { 18 variable dtrace {} 19} 20 21# ### ### ### ######### ######### ######### 22## Start a new dialog server. 23 24proc ::dialog::setup {type cookie {ssl 0}} { 25 variable id 26 variable port 27 28 switch -- $type { 29 server {set server 1} 30 client {set server 0} 31 default {return -code error "Bad dialog type \"$type\", expected server, or client"} 32 } 33 34 set id [::coserv::start "$type: $cookie"] 35 ::coserv::run $id { 36 set responses {} 37 set strace {} 38 set received {} 39 set conn {} 40 set ilog {} 41 42 proc Log {text} { 43 global ilog ; lappend ilog $text 44 } 45 proc Strace {text} { 46 global strace ; lappend strace $text 47 } 48 proc Exit {sock reason} { 49 Strace $reason 50 Log [list $reason $sock] 51 close $sock 52 Done 53 } 54 proc Done {} { 55 global main strace ilog 56 comm::comm send $main [list dialog::done [list $strace $ilog]] 57 return 58 } 59 proc ClearTraces {} { 60 global strace ; set strace {} 61 global ilog ; set ilog {} 62 return 63 } 64 proc Step {sock} { 65 global responses trace 66 67 if {![llength $responses]} { 68 Exit $sock empty 69 return 70 } 71 72 set now [lindex $responses 0] 73 set responses [lrange $responses 1 end] 74 75 Log [list ** $sock $now] 76 eval [linsert $now end $sock] 77 return 78 } 79 80 # Step commands ... 81 82 proc .Crlf {sock} { 83 Strace crlf 84 Log crlf 85 fconfigure $sock -translation crlf 86 Step $sock 87 return 88 } 89 proc .Binary {sock} { 90 Strace bin 91 Log binary 92 fconfigure $sock -translation binary 93 Step $sock 94 return 95 } 96 proc .HaltKeep {sock} { 97 Log halt.keep 98 Done 99 global responses 100 set responses {} 101 # No further stepping. 102 # This keeps the socket open. 103 # Needs external reset/cleanup 104 return 105 } 106 proc .Send {line sock} { 107 Strace [list >> $line] 108 Log [list >> $line] 109 110 if {[catch { 111 puts $sock $line 112 flush $sock 113 } msg]} { 114 Exit $sock broken 115 return 116 } 117 Step $sock 118 return 119 } 120 proc .Geval {script sock} { 121 Log geval 122 uplevel #0 $script 123 Step $sock 124 return 125 } 126 proc .Eval {script sock} { 127 Log eval 128 eval $script 129 Step $sock 130 return 131 } 132 proc .SendGvar {vname sock} { 133 upvar #0 $vname line 134 .Send $line $sock 135 return 136 } 137 proc .Receive {sock} { 138 set aid [after 10000 [list Timeout $sock]] 139 fileevent $sock readable [list Input $aid $sock] 140 # No "Step" here. Comes through input. 141 Log " Waiting \[$aid\]" 142 return 143 } 144 proc Input {aid sock} { 145 global received 146 if {[eof $sock]} { 147 # Clean the timer up 148 after cancel $aid 149 Exit $sock close 150 return 151 } 152 if {[gets $sock line] < 0} { 153 Log " **|////|**" 154 return 155 } 156 157 Log "-- -v-" 158 Log " Events off \[$aid, $sock\]" 159 fileevent $sock readable {} 160 after cancel $aid 161 162 Strace [list << $line] 163 Log [list << $line] 164 lappend received $line 165 166 # Now we can step further 167 Step $sock 168 return 169 } 170 proc Timeout {sock} { 171 Exit $sock timeout 172 return 173 } 174 proc Accept {sock host port} { 175 fconfigure $sock -blocking 0 176 ClearTraces 177 Step $sock 178 return 179 } 180 181 proc Server {} { 182 global port 183 # Start listener for dialog 184 set listener [socket -server Accept 0] 185 set port [lindex [fconfigure $listener -sockname] 2] 186 # implied return of <port> 187 } 188 189 proc Client {port} { 190 global conn 191 catch {close $conn} 192 193 set conn [set sock [socket localhost $port]] 194 fconfigure $sock -blocking 0 195 ClearTraces 196 Log [list Client @ $port = $sock] 197 Log [list Channels $port = [lsort [file channels]]] 198 Step $sock 199 return 200 } 201 } 202 203 if {$ssl} { 204 # Replace various commands with tls aware variants 205 coserv::run $id [list set devtools [tcllibPath devtools]] 206 coserv::run $id { 207 package require tls 208 209 tls::init \ 210 -keyfile $devtools/transmitter.key \ 211 -certfile $devtools/transmitter.crt \ 212 -cafile $devtools/ca.crt \ 213 -ssl2 1 \ 214 -ssl3 1 \ 215 -tls1 0 \ 216 -require 1 217 218 proc Server {} { 219 global port 220 # Start listener for dialog 221 set listener [tls::socket -server Accept 0] 222 set port [lindex [fconfigure $listener -sockname] 2] 223 # implied return of <port> 224 } 225 226 proc Client {port} { 227 global conn 228 catch {close $conn} 229 230 set conn [set sock [tls::socket localhost $port]] 231 fconfigure $sock -blocking 0 232 ClearTraces 233 Log [list Client @ $port = $sock] 234 Log [list Channels $port = [lsort [file channels]]] 235 Step $sock 236 return 237 } 238 } 239 } 240 241 if {$server} { 242 set port [coserv::run $id {Server}] 243 } 244} 245 246proc ::dialog::runclient {port} { 247 variable id 248 variable dtrace {} 249 coserv::task $id [list Client $port] 250 return 251} 252 253proc ::dialog::dialog_set {response_script} { 254 begin 255 uplevel 1 $response_script 256 end 257 return 258} 259 260proc ::dialog::begin {{cookie {}}} { 261 variable id 262 ::coserv::task $id [list set responses {}] 263 log::log debug "+============================================ $cookie \\\\" 264 return 265} 266 267proc ::dialog::cmd {command} { 268 variable id 269 ::coserv::task $id [list lappend responses $command] 270 return 271} 272 273proc ::dialog::end {} { 274 # This implicitly waits for all preceding commands (which are async) to complete. 275 variable id 276 set responses [::coserv::run $id [list set responses]] 277 ::coserv::run $id {set received {}} 278 log::log debug |\t[join $responses \n|\t] 279 log::log debug +--------------------------------------------- 280 return 281} 282 283proc ::dialog::crlf. {} {cmd .Crlf} 284proc ::dialog::binary. {} {cmd .Binary} 285proc ::dialog::send. {line} {cmd [list .Send $line]} 286proc ::dialog::receive. {} {cmd .Receive} 287proc ::dialog::respond. {line} {receive. ; send. $line} 288proc ::dialog::request. {line} {send. $line ; receive.} 289proc ::dialog::halt.keep. {} {cmd .HaltKeep} 290proc ::dialog::sendgvar. {vname} {cmd [list .SendGvar $vname]} 291proc ::dialog::reqgvar. {vname} {sendgvar. $vname ; receive.} 292proc ::dialog::geval. {script} {cmd [list .Geval $script]} 293proc ::dialog::eval. {script} {cmd [list .Eval $script]} 294 295proc ::dialog::done {traces} { 296 variable dtrace $traces 297 return 298} 299 300proc ::dialog::waitdone {} { 301 variable dtrace 302 303 # Loop until we have data from the dialog subprocess. 304 # IOW writes which do not create data are ignored. 305 while {![llength $dtrace]} { 306 vwait ::dialog::dtrace 307 } 308 309 foreach {strace ilog} $dtrace break 310 set dtrace {} 311 312 log::log debug +--------------------------------------------- 313 log::log debug |\t[join $strace \n|\t] 314 log::log debug +--------------------------------------------- 315 log::log debug /\t[join $ilog \n/\t] 316 log::log debug "+============================================ //" 317 return $strace 318} 319 320proc ::dialog::received {} { 321 # Wait for all preceding commands to complete. 322 variable id 323 set received [::coserv::run $id [list set received]] 324 ::coserv::run $id [list set received {}] 325 return $received 326} 327 328proc ::dialog::listener {} { 329 variable port 330 return $port 331} 332 333proc ::dialog::shutdown {} { 334 variable id 335 variable port 336 variable dtrace 337 338 ::coserv::shutdown $id 339 340 set id {} 341 set port {} 342 set dtrace {} 343 return 344} 345 346# ### ### ### ######### ######### ######### 347