00001 set Release(socksend.tcl) {$Header: /home/cvs/tktest/socksend/socksend.tcl,v 1.21 2015/11/16 18:26:15 clif Exp $} 00002 set SockData(debug) 0 00003 00004 proc socksendDebug {str} { 00005 global SockData 00006 if {!$SockData(debug)} {return} 00007 if {![info exists SockData(dbgout)]} { 00008 set SockData(dbgout) [open /tmp/tkreplSS-[pid].txt w] 00009 } 00010 puts $SockData(dbgout) $str 00011 flush $SockData(dbgout) 00012 } 00013 00014 socksendDebug "I AM: [tk appname] -- [info script]" 00015 proc socksendsetup {port} { 00016 global SockData 00017 if {[catch {socket -server sockconnect $port} ret]} { 00018 puts stderr "socksendsetup: (set up server) socket $port failed ($ret)" 00019 error $ret $ret 00020 } 00021 } 00022 00023 proc sockconnect {channel hostaddr port} { 00024 global SockData 00025 global ReplayData 00026 set name [gets $channel] 00027 set id $name 00028 set SockData($id,channel) $channel 00029 00030 fileevent $channel readable "sockreceive $channel" 00031 after 500 [list ConnectToApp $id] 00032 } 00033 00034 proc sockreceive {channel} { 00035 global ReplayData 00036 global SockData 00037 00038 if [eof $channel] { 00039 close $channel 00040 00041 set ReplayData(ConnectedApps) {} 00042 set ReplayData(Status) Disconnected 00043 00044 return 00045 } 00046 set line [gets $channel] 00047 socksendDebug "READ: $line" 00048 append SockData($channel,Command) $line\n 00049 if {[info complete $SockData($channel,Command)]} { 00050 # processData might not return quickly - if 00051 # there is a vwait in the command invoked, for instance. 00052 # Must clear that data buffer before invoking this to avoid 00053 # multiple copies of the command being invoked. 00054 00055 set data $SockData($channel,Command) 00056 set SockData($channel,Command) "" 00057 processData $data 00058 } 00059 } 00060 00061 proc processData {data} { 00062 socksendDebug "PROCESS: $data" 00063 set fail [catch {uplevel #0 $data} rtn] 00064 if {$fail} { 00065 # Sigh. I don't like putting a call to higher level 00066 # code in a low level function, but there's no good way 00067 # to pass the error condition back up to application code 00068 # from a function invoked from the event loop. 00069 socksendDebug "ERROR: $data \n Rtn: $rtn" 00070 # RemoteMsgToUser "ERROR: $data \n Rtn: $rtn" high 00071 } 00072 } 00073 00074 proc sockappsetup {his_name his_port {his_addr localhost}} { 00075 socksendDebug "his_name: $his_name his_port $his_port his_addr: $his_addr" 00076 global SockData 00077 set count 0 00078 while {[catch {socket $his_addr $his_port} ch]} { 00079 incr count 00080 if {$count > 20} { 00081 tk_messageBox -type ok -message "Unable to contact $his_name ($his_port at $his_addr)" 00082 exit 00083 } 00084 after 1000 00085 } 00086 fileevent $ch readable "sockreceive $ch" 00087 set SockData($his_name,channel) $ch 00088 # puts $ch [file tail [info script]] 00089 puts $ch [tk appname] 00090 flush $ch 00091 socksendDebug "OPENED CLIENT SOCKET as [tk appname]" 00092 } 00093 00094 proc tkrsend {args} { 00095 return [eval socksend $args] 00096 } 00097 00098 proc tkerror {msg} { 00099 puts "TKERROR: $msg" 00100 } 00101 00102 proc socksendopen {id port {host localhost}} { 00103 global SockData 00104 set SockData($id,channel) [socket $host $port] 00105 fileevent $ch readable "sockreceive $SockData($id,channel)" 00106 } 00107 00108 proc socksend {args} { 00109 00110 global ReplayData 00111 global SockData 00112 00113 if {[info exists ReplayData(RecordingOn)] && 00114 ($ReplayData(RecordingOn) ==1)} { 00115 whereAmI-Server 00116 } 00117 00118 if {[string first "-a" $args] == 0} { 00119 set args [string trim [string range $args 6 end]] 00120 } 00121 lassign $args key val 00122 set key [concat {*}$key] 00123 socksendDebug "SOCKSEND: $args -- $key -- $val" 00124 if {([string first Destroy $val] > 0) && 00125 ([string first "MsgToU" $val] < 0)} { 00126 if {![string equal "" [info procs whereAmI-Client]]} { 00127 whereAmI-Client 00128 } 00129 } 00130 socksendDebug "SOCKSEND: puts $SockData($key,channel) '$val'" 00131 puts $SockData($key,channel) $val 00132 flush $SockData($key,channel) 00133 } 00134 00135 proc GetUniqueSocketId {} { 00136 error GetUniqueSocketId 00137 }