/usr/lib/gcl-2.6.12-prof/gcl-tk/decode.tcl is in gcl 2.6.12-47.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | # this file contains the protocol for receiving connections from GCL and
# other lisps [or other languages]
# The communication is via a socket, and the data is packaged up into
# packets, which we track letting the other side know how much is actually
# received. This protocol is to prevent problems with flooding a
# communications channel. The sender knows how many bytes are in the pipe.
# the outer wrapper is
# { char magic;
# unsigned short length; /* including the header */
# unsigned short received; /* incremental number of bytes received at the
# other end of the channel */
#
# (MAGIC1 MAGIC2 TYPE FLAG BODY-LENGTH NIL NIL MSG-INDEX NIL NIL)
set GclMTypes { m_not_used
m_create_command
m_reply
m_call
m_tcl_command
m_tcl_command_wait_response
m_tcl_clear_connection
m_tcl_link_text_variable
m_set_lisp_loc
m_tcl_set_text_variable
m_tcl_unlink_text_variable}
proc GclDecodeMsg { msg } {
# char magic1; \06
# char magic2; 'A'
# char type; m_*
# unsigned char flag;
# unsigned char size[3]; /* of body */
# unsigned char msg_id[3];
# char body[1];
global GclMTypes
if { [string match "\06A*" $msg] } {
binary scan [string range $msg 2 end] ccsc type flag bodyLo bodyHi
set bodyLength [expr ($bodyLo & 0xffff)+ ($bodyHi >> 16)]
set index [msgIndex $msg]
set ans "xMsg-id=$index, type= [lindex $GclMTypes $type], length=$bodyLength, body=[string range $msg 10 [expr 10 + $bodyLength-1]]"
} else {set ans "invalidmsg:<$msg>" }
}
#proc GclmsgIndex { msg } {
# binary scan [string range $msg 7 9] sc indLo indHi
# set index [expr ($indLo & 0xffff)+ ($indHi >> 16)]
# return $index
#}
proc Gclget3Bytes { s } {
binary scan $s "sc" lo hi
return [expr { ($lo & 0xffff) + ($hi << 16) }]
}
proc GclMake3Bytes { n } {
return [ string range [binary format i $n] 0 2]
}
proc debugSend { msg } {
puts stderr $msg
flush stderr
}
proc GclAnswerSocket { host port pid } {
global GclSock GclPdata GclPacket
set sock [socket $host $port]
setupPacket $sock
fconfigure $sock -blocking 0 -translation {binary binary}
# debugSend fconfigure:$sock:[fconfigure $sock]
set GclSock $sock
catch { unset GclPdata(data,$sock) }
fileevent $sock readable "GclReadAndAct1 $sock"
set GclPdata(pid,$sock) $pid
return $sock
}
proc setupPacket { sock } {
global GclPacket
# data including 5 byte headers
set GclPacket(indata,$sock) ""
set GclPacket(received,$sock) 0
set GclPacket(sent_not_received,$sock) 0
# the data after stripping headers
set GclPacket(outdata,$sock) ""
}
proc GclRead1 { sock } {
global GclPacket
upvar #0 GclPacket(indata,$sock) indata
set recd 0
append indata [read $sock]
set ll 0
while { [set l [string length $indata]] >= 5 } {
binary scan $indata "css" magic length received
# debugSend "magic=$magic,length=$length,received:=$received,indata=$indata"
# -122 = signedchar(0206)
if { $magic != -122 } {
error "bad magic"
}
# debugSend "test: $l >= $length + 5"
if { $l >= $length } {
append GclPacket(outdata,$sock) [string range $indata 5 [expr $length -1]]
set indata [string range $indata $length end]
incr recd $received
incr ll $length
} else { break
}
}
incr GclPacket(received,$sock) $ll
if { $recd } {
incr GclPacket(sent_not_received,$sock) -$recd
}
if { $GclPacket(received,$sock) > 1500 } {
sendReceiveConfirmation $sock
}
set res $GclPacket(outdata,$sock)
set GclPacket(outdata,$sock) ""
# debugSend "GclRead1--><$res>"
return $res
}
proc sendReceiveConfirmation { sock } {
GclWrite1 $sock ""
}
proc GclWrite1 { sock data } {
global GclPacket
# debugSend "entering GclWrite1"
set length [expr 5 + [string length $data]]
set hdr \206[binary format ss $length $GclPacket(received,$sock)]
# debugSend "hdr=$hdr, [array get GclPacket *]"
set GclPacket(received,$sock) 0
incr GclPacket(sent_not_received,$sock) $length
#debugSend "GclWrite1:<$hdr$data>"
puts -nonewline $sock $hdr$data
flush $sock
}
proc GclReadAndAct1 { sock } {
global GclPdata GclMTypes
upvar #0 GclPdata(data,$sock) msg
set read [GclRead1 $sock]
if { [string length $read] == 0 } {
if { [eof $sock] } {
# debugSend "exitting since $sock is closed"
exit 1
}
return ""
}
append msg $read
while { [set l [string length $msg]] >= 10 } {
#debugSend "msg=<$msg>"
#debugSend [GclDecodeMsg $msg]
binary scan $msg sccsc magic type flag bodyLo bodyHi
if { $magic != 16646 } {
error "bad magic:[string range $msg 0 1]"
}
set bodyLength [expr ($bodyLo & 0xffff)+ ($bodyHi >> 16)]
if { $l >= 10+$bodyLength } {
set toeval [list [lindex $GclMTypes $type] $msg [string range $msg 10 [expr 10 + $bodyLength-1]]]
set msg [string range $msg [expr 10 + $bodyLength] end]
#debugSend toeval=$toeval
if { [catch { eval $toeval } err] } {
puts stderr "error in [lindex $toeval 0] [string range [lindex $toeval 1 ] 0 13]... [lindex $toeval 2]: $err"
flush stderr
}
}
}
}
proc GclGetCString {s } {
return [string range $s 0 [expr [string first \0 $s] -1]]
}
set GclSockMsgId 0
proc sock_write_str {typeflag text } {
global GclSock GclSockMsgId
set msg "\06A$typeflag[GclMake3Bytes [string length $text]][GclMake3Bytes [incr GclSockMsgId]]$text"
#debugSend sending:[GclDecodeMsg $msg]
GclWrite1 $GclSock $msg
}
proc GclGenericCommand { n arg } {
global GclSock
# 2 == [lsearch $GclMTypes m_reply]
sock_write_str "\3\0" "[GclMake3Bytes $n]$arg"
signalParent $GclSock
}
proc GclGenericCommandStringify { n arglist lis } {
global GclSock
set i 0
set ans "[GclMake3Bytes $n]("
foreach v $lis {
if { "s" == "[string range $arglist $i $i]" } {
append ans " \"" $v "\""
} else { append ans " " $v
}
}
append ans ")"
sock_write_str "\3\0" $ans
signalParent $GclSock
}
proc m_create_command { msg body } {
#debugSend "in m_create_command"
set n [Gclget3Bytes $body]
set arglist [GclGetCString [string range $body 3 end]]
# "debugSend callback_$n:args=\$args ; GclGenericCommandStringify $n $arglist \$args" \
if { "$arglist" == "" } {
proc callback_$n { { arg1 "" } } "GclGenericCommand $n \$arg1"
} else {
proc callback_$n { args } "GclGenericCommandStringify $n $arglist \$args"
}
}
proc m_tcl_command { msg body } {
set body [string trimright $body "\0"]
# set body [GclGetCString $body]
# set fail [catch { eval $body } res]
# set fail [catch { eval $body } res]
eval $body
# set com "update idletasks"
#after cancel $com
#after 5 $com
# update idletasks
# puts stderr "doing $body" ; flush stderr
# debugSend "in eval of <$body>: fail=$fail,res=<$res>"
}
proc m_tcl_command_wait_response { msg body } {
global GclSock
set body [string trimright $body "\0"]
# set body [GclGetCString $body]
set fail [catch { eval $body } res]
# 2 == [lsearch $GclMTypes m_reply]
sock_write_str "\2\0" "$fail[string range $msg 7 9]$res"
# debugSend " signalParent $GclSock"
# no need to signal other side is waiting.
# signalParent $GclSock
}
proc m_tcl_clear_connection { msg body } {
global GclSock
flush $GclSock
set GclPdata($GclSock,data) ""
}
proc m_tcl_set_text_variable { msg body } {
set n [string first \0 $body]
set [string range $body 0 [expr $n -1]] [string range $body [expr $n+1] end]
}
proc m_tcl_link_text_variable { msg body } {
global GclPdata
set i [Gclget3Bytes $body]
set name [string range $body 3 end]
uplevel #0 trace variable wu $name "GclTellLispVarChanged $i"
}
proc signalParent1 {sock } {
global GclPdata GclPacket
if { $GclPacket(sent_not_received,$sock) } {
exec kill -s SIGUSR1 $GclPdata(pid,$sock) &
}
}
proc signalParent {sock } {
global delay
set com "signalParent1 $sock"
after cancel $com
after 5 $com
}
proc GclTellLispVarChanged { i name1 name2 op } {
global GclPdata
upvar #0 $name1 val
# 8 == [lsearch $GclMTypes m_set_lisp_loc]
sock_write_str \8\0 "[GclMake3Bytes $i]$val"
signalParent $GclSock
}
proc m_tcl_unlink_text_variable { msg body } {
set i [Gclget3Bytes $body]
set name [string range $body 3 end]
trace vdelete $name wu "GclTellLispVarChanged $i"
}
|