| 1 | #!/bin/sh
|
|---|
| 2 | # Copyright (c) 1999-2000 Jean-Claude Wippler <jcw@equi4.com>
|
|---|
| 3 | #
|
|---|
| 4 | # Tequilas - the "Tequila Server" implements shared persistent arrays
|
|---|
| 5 | #\
|
|---|
| 6 | exec tclkit "$0" ${1+"$@"}
|
|---|
| 7 |
|
|---|
| 8 | # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|---|
| 9 | # Imlementation notes:
|
|---|
| 10 | #
|
|---|
| 11 | # Commands starting with "Tqs" can be called from the remote client
|
|---|
| 12 | # The rest uses lowercase "tqs" to prevent this (and for uniqueness)
|
|---|
| 13 | #
|
|---|
| 14 | # There is one global array which is used for all information which
|
|---|
| 15 | # this server needs to carry around and track, called "tqs_info":
|
|---|
| 16 | #
|
|---|
| 17 | # tqs_info(pending) - id of pending "after" request, unset if none
|
|---|
| 18 | # tqs_info(timeout) - milliSecs before timed commit, unset if never
|
|---|
| 19 | # tqs_info(verbose) - log level: 0=off, 1=req's, 2=notify, 3=reply
|
|---|
| 20 | #
|
|---|
| 21 | # External views (type "X") are stored as files in directory, one item
|
|---|
| 22 | # per text file. This can be used to store large amounts of text in
|
|---|
| 23 | # regular files, outside Metakit (though commit doesn't apply to them):
|
|---|
| 24 | #
|
|---|
| 25 | # tqs_external(view) - directory name, set for each external view
|
|---|
| 26 | #
|
|---|
| 27 | # Valid while processing an incoming request:
|
|---|
| 28 | # tqs_info(port) - socket name of current client request
|
|---|
| 29 | #
|
|---|
| 30 | # The following will be defined for individual views:
|
|---|
| 31 | # tqs_notify($view) - socket name of client to notify on changes
|
|---|
| 32 | # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|---|
| 33 |
|
|---|
| 34 | # conditonal logging output
|
|---|
| 35 | proc tqsPuts {level msg} {
|
|---|
| 36 | global tqs_info
|
|---|
| 37 | if {$level <= $tqs_info(verbose)} {
|
|---|
| 38 | puts $msg
|
|---|
| 39 | }
|
|---|
| 40 | }
|
|---|
| 41 |
|
|---|
| 42 | # return a displayable string of limited length
|
|---|
| 43 | proc tqsDisplay {str len} {
|
|---|
| 44 | if {[string length $str] > $len} {
|
|---|
| 45 | set str "[string range $str 0 $len]..."
|
|---|
| 46 | }
|
|---|
| 47 | regsub -all {[^ -~]} $str {?} str
|
|---|
| 48 | return $str
|
|---|
| 49 | }
|
|---|
| 50 |
|
|---|
| 51 | # remote execution of any Metakit command, added 20-02-2000
|
|---|
| 52 | proc TqsRemote {cmd args} {
|
|---|
| 53 | eval mk::$cmd $args
|
|---|
| 54 | }
|
|---|
| 55 |
|
|---|
| 56 | # return the names of all views currently on file
|
|---|
| 57 | proc TqsInfo {} {
|
|---|
| 58 | mk::file views tqs
|
|---|
| 59 | }
|
|---|
| 60 |
|
|---|
| 61 | # get or set log level (see above for meaning of values 0..3)
|
|---|
| 62 | proc TqsVerbose {{level ""}} {
|
|---|
| 63 | global tqs_info
|
|---|
| 64 | if {$level != ""} {
|
|---|
| 65 | set tqs_info(verbose) $level
|
|---|
| 66 | }
|
|---|
| 67 | return $tqs_info(verbose)
|
|---|
| 68 | }
|
|---|
| 69 |
|
|---|
| 70 | # define a view (Metakit's equivalent concept for a Tcl array)
|
|---|
| 71 | # if the second argument is true, all existing data is removed
|
|---|
| 72 | # the third arg is used to specify a binary (B) of memo format (M)
|
|---|
| 73 | # if the third arg is "X", use a directory with files for storage
|
|---|
| 74 | proc TqsDefine {view {clear 0} {type S}} {
|
|---|
| 75 | if {$type == "X"} {
|
|---|
| 76 | global tqs_external
|
|---|
| 77 | set tqs_external($view) ""
|
|---|
| 78 | if {$clear} {
|
|---|
| 79 | catch {file delete -force $view.data}
|
|---|
| 80 | tqsTrace $view "" u
|
|---|
| 81 | }
|
|---|
| 82 | file mkdir $view.data
|
|---|
| 83 | #catch {mk::view delete tqs.$view}
|
|---|
| 84 | } else {
|
|---|
| 85 | mk::view layout tqs.$view "name text:$type date:I"
|
|---|
| 86 | if {$clear && [mk::view size tqs.$view] > 0} {
|
|---|
| 87 | mk::view size tqs.$view 0
|
|---|
| 88 | tqsTrace $view "" u
|
|---|
| 89 | }
|
|---|
| 90 | #file delete -force $view.data
|
|---|
| 91 | }
|
|---|
| 92 | return
|
|---|
| 93 | }
|
|---|
| 94 |
|
|---|
| 95 | # get rid of a view
|
|---|
| 96 | proc TqsUndefine {view} {
|
|---|
| 97 | global tqs_external
|
|---|
| 98 | if {[info exists tqs_external($view)]} {
|
|---|
| 99 | file delete -force $view.data
|
|---|
| 100 | unset tqs_external($view)
|
|---|
| 101 | } else {
|
|---|
| 102 | mk::view delete tqs.$view
|
|---|
| 103 | }
|
|---|
| 104 | tqsTrace $view "" u
|
|---|
| 105 | return
|
|---|
| 106 | }
|
|---|
| 107 |
|
|---|
| 108 | # return the list of all keys, like "array names view"
|
|---|
| 109 | proc TqsNames {view} {
|
|---|
| 110 | set result {}
|
|---|
| 111 | global tqs_external
|
|---|
| 112 | if {[info exists tqs_external($view)]} {
|
|---|
| 113 | foreach x [glob -nocomplain $view.data/*] {
|
|---|
| 114 | regsub {.*/} $x {} x
|
|---|
| 115 | lappend result $x
|
|---|
| 116 | }
|
|---|
| 117 | } else {
|
|---|
| 118 | mk::loop c tqs.$view {
|
|---|
| 119 | lappend result [mk::get $c name]
|
|---|
| 120 | }
|
|---|
| 121 | }
|
|---|
| 122 | return $result
|
|---|
| 123 | }
|
|---|
| 124 |
|
|---|
| 125 | # return the number of keys, like "array size view"
|
|---|
| 126 | proc TqsSize {view} {
|
|---|
| 127 | set result {}
|
|---|
| 128 | global tqs_external
|
|---|
| 129 | if {[info exists tqs_external($view)]} {
|
|---|
| 130 | set result [llength [glob -nocomplain "$view.data/*"]]
|
|---|
| 131 | } else {
|
|---|
| 132 | set result [mk::view size tqs.$view]
|
|---|
| 133 | }
|
|---|
| 134 | return $result
|
|---|
| 135 | }
|
|---|
| 136 |
|
|---|
| 137 | # return an existing value, lookup by key, like "set view(key)"
|
|---|
| 138 | proc TqsGet {view key} {
|
|---|
| 139 | global tqs_external
|
|---|
| 140 | if {[info exists tqs_external($view)]} {
|
|---|
| 141 | set fd [open $view.data/$key]
|
|---|
| 142 | fconfigure $fd -translation binary
|
|---|
| 143 | set v [read $fd]
|
|---|
| 144 | close $fd
|
|---|
| 145 | return $v
|
|---|
| 146 | } else {
|
|---|
| 147 | set n [mk::select tqs.$view name $key]
|
|---|
| 148 | mk::get tqs.$view!$n text ;# throws error if absent
|
|---|
| 149 | }
|
|---|
| 150 | }
|
|---|
| 151 |
|
|---|
| 152 | # store a value, create if necessary, like "set view(key) data"
|
|---|
| 153 | # the optional last arg can be used to force a specific timestamp
|
|---|
| 154 | proc TqsSet {view key data {timestamp ""}} {
|
|---|
| 155 | global tqs_external
|
|---|
| 156 | if {[info exists tqs_external($view)]} {
|
|---|
| 157 | set fd [open $view.data/$key w]
|
|---|
| 158 | fconfigure $fd -translation binary
|
|---|
| 159 | puts -nonewline $fd $data
|
|---|
| 160 | close $fd
|
|---|
| 161 | # timestamp is ignored
|
|---|
| 162 | } else {
|
|---|
| 163 | set n [mk::select tqs.$view name $key]
|
|---|
| 164 | if {[llength $n] == 0} {
|
|---|
| 165 | set n [mk::view size tqs.$view]
|
|---|
| 166 | } elseif {[mk::get tqs.$view!$n text] == $data} {
|
|---|
| 167 | return ;# no change, ignore
|
|---|
| 168 | }
|
|---|
| 169 | if {$timestamp == ""} {
|
|---|
| 170 | set timestamp [clock seconds]
|
|---|
| 171 | }
|
|---|
| 172 | mk::set tqs.$view!$n name $key text $data date $timestamp
|
|---|
| 173 | }
|
|---|
| 174 | tqsTrace $view $key w
|
|---|
| 175 | return
|
|---|
| 176 | }
|
|---|
| 177 |
|
|---|
| 178 | # Append a value, create if entry did not exist
|
|---|
| 179 | proc TqsAppend {view key data} {
|
|---|
| 180 | global tqs_external
|
|---|
| 181 | if {[info exists tqs_external($view)]} {
|
|---|
| 182 | set fd [open $view.data/$key a]
|
|---|
| 183 | fconfigure $fd -translation binary
|
|---|
| 184 | puts -nonewline $fd $data
|
|---|
| 185 | close $fd
|
|---|
| 186 | } else {
|
|---|
| 187 | set n [mk::select tqs.$view name $key]
|
|---|
| 188 | if {[llength $n] > 0} {
|
|---|
| 189 | if {[string length $data] == 0} then return ;# no change
|
|---|
| 190 | set data "[mk::get tqs.$view!$n text]$data"
|
|---|
| 191 | }
|
|---|
| 192 | mk::set tqs.$view!$n name $key text $data date [clock seconds]
|
|---|
| 193 | }
|
|---|
| 194 | tqsTrace $view $key w
|
|---|
| 195 | return
|
|---|
| 196 | }
|
|---|
| 197 |
|
|---|
| 198 | # delete an existing entry by key, similar to "unset view(key)"
|
|---|
| 199 | proc TqsUnset {view key} {
|
|---|
| 200 | global tqs_external
|
|---|
| 201 | if {[info exists tqs_external($view)]} {
|
|---|
| 202 | file delete $view.data/$key
|
|---|
| 203 | } else {
|
|---|
| 204 | set n [mk::select tqs.$view name $key]
|
|---|
| 205 | if {[llength $n] == 0} {
|
|---|
| 206 | return ;# no change, ignore
|
|---|
| 207 | }
|
|---|
| 208 | mk::row delete tqs.$view!$n
|
|---|
| 209 | }
|
|---|
| 210 | tqsTrace $view $key u
|
|---|
| 211 | return
|
|---|
| 212 | }
|
|---|
| 213 |
|
|---|
| 214 | # return all key/value pairs, like "array get view"
|
|---|
| 215 | # if set, the optional arg sets up change notification
|
|---|
| 216 | proc TqsGetAll {view {tracking 0}} {
|
|---|
| 217 | set result {}
|
|---|
| 218 | global tqs_external
|
|---|
| 219 | if {[info exists tqs_external($view)]} {
|
|---|
| 220 | foreach x [TqsNames $view] {
|
|---|
| 221 | lappend result $x [TqsGet $view $x]
|
|---|
| 222 | }
|
|---|
| 223 | } else {
|
|---|
| 224 | mk::loop c tqs.$view {
|
|---|
| 225 | eval lappend result [mk::get $c name text]
|
|---|
| 226 | }
|
|---|
| 227 | }
|
|---|
| 228 | if {$tracking} { tqsSubscribe $view }
|
|---|
| 229 | return $result
|
|---|
| 230 | }
|
|---|
| 231 |
|
|---|
| 232 | # like TqsGetAll, returns modification dates instead of contents
|
|---|
| 233 | # this can be used by the client to synchronize and track dates
|
|---|
| 234 | # if set, the optional arg sets up change notification
|
|---|
| 235 | proc TqsListing {view {tracking 0}} {
|
|---|
| 236 | set result {}
|
|---|
| 237 | global tqs_external
|
|---|
| 238 | if {[info exists tqs_external($view)]} {
|
|---|
| 239 | foreach x [TqsNames $view] {
|
|---|
| 240 | lappend result $x [file mtime $view.data/$x]
|
|---|
| 241 | }
|
|---|
| 242 | } else {
|
|---|
| 243 | mk::loop c tqs.$view {
|
|---|
| 244 | eval lappend result [mk::get $c name date]
|
|---|
| 245 | }
|
|---|
| 246 | }
|
|---|
| 247 | if {$tracking} { tqsSubscribe $view }
|
|---|
| 248 | return $result
|
|---|
| 249 | }
|
|---|
| 250 |
|
|---|
| 251 | # called to set up notification for a client
|
|---|
| 252 | proc tqsSubscribe {view} {
|
|---|
| 253 | global tqs_info tqs_notify
|
|---|
| 254 |
|
|---|
| 255 | # remember the client IP and listening number for this view
|
|---|
| 256 | tqsPuts 1 "Notification set up for '$view': $tqs_info(port)"
|
|---|
| 257 | lappend tqs_notify($view) $tqs_info(port)
|
|---|
| 258 | }
|
|---|
| 259 |
|
|---|
| 260 | # called to unset all notifications for a client
|
|---|
| 261 | proc tqsUnsubscribe {port} {
|
|---|
| 262 | global tqs_notify
|
|---|
| 263 |
|
|---|
| 264 | foreach {k v} [array get tqs_notify] {
|
|---|
| 265 | set n [lsearch -exact $v $port]
|
|---|
| 266 | if {$n >= 0} {
|
|---|
| 267 | tqsPuts 1 " Forget notify for $k"
|
|---|
| 268 |
|
|---|
| 269 | if {[llength $v] > 1} {
|
|---|
| 270 | set tqs_notify($k) [lreplace $v $n $n]
|
|---|
| 271 | } else {
|
|---|
| 272 | unset tqs_notify($k)
|
|---|
| 273 | tqsPuts 1 " No more notifications for $k"
|
|---|
| 274 | }
|
|---|
| 275 | }
|
|---|
| 276 | }
|
|---|
| 277 | }
|
|---|
| 278 |
|
|---|
| 279 | # set a number of key/value pairs, like "array set view pairs"
|
|---|
| 280 | proc TqsSetAll {view pairs} {
|
|---|
| 281 | foreach {key value} $pairs {
|
|---|
| 282 | TqsSet $view $key $value
|
|---|
| 283 | }
|
|---|
| 284 | }
|
|---|
| 285 |
|
|---|
| 286 | # save changes to file now
|
|---|
| 287 | proc TqsCommit {} {
|
|---|
| 288 | global tqs_info
|
|---|
| 289 |
|
|---|
| 290 | set n [clock clicks]
|
|---|
| 291 | mk::file commit tqs
|
|---|
| 292 | tqsPuts 1 "Commit done ([expr {[clock clicks] - $n}])"
|
|---|
| 293 |
|
|---|
| 294 | after cancel TqsCommit
|
|---|
| 295 | catch {unset tqs_info(pending)}
|
|---|
| 296 | return
|
|---|
| 297 | }
|
|---|
| 298 |
|
|---|
| 299 | # change commit timer, default is to commit with explicit calls
|
|---|
| 300 | proc TqsTimer {{timer ""}} {
|
|---|
| 301 | global tqs_info
|
|---|
| 302 |
|
|---|
| 303 | after cancel TqsCommit
|
|---|
| 304 |
|
|---|
| 305 | if {$timer == ""} {
|
|---|
| 306 | catch {unset tqs_info(timeout)}
|
|---|
| 307 | } else {
|
|---|
| 308 | if {[info exists tqs_info(pending)]} {
|
|---|
| 309 | set tqs_info(pending) [after $timer TqsCommit]
|
|---|
| 310 | }
|
|---|
| 311 | set tqs_info(timeout) $timer
|
|---|
| 312 | }
|
|---|
| 313 | }
|
|---|
| 314 |
|
|---|
| 315 | # handles tracing of all view changes (there's no read tracing)
|
|---|
| 316 | # this is also the place where delayed commits are scheduled
|
|---|
| 317 | proc tqsTrace {view key operation} {
|
|---|
| 318 | global tqs_info tqs_notify
|
|---|
| 319 |
|
|---|
| 320 | if [info exists tqs_notify($view)] {
|
|---|
| 321 | switch $operation {
|
|---|
| 322 | w { set req [list Set $view $key [TqsGet $view $key]] }
|
|---|
| 323 | u { set req [list Unset $view $key] }
|
|---|
| 324 | }
|
|---|
| 325 |
|
|---|
| 326 | # this is the data that gets sent out
|
|---|
| 327 | set msg "[string length $req]\n$req"
|
|---|
| 328 |
|
|---|
| 329 | foreach p $tqs_notify($view) {
|
|---|
| 330 | if {$p == $tqs_info(port)} continue ;# skip originator
|
|---|
| 331 |
|
|---|
| 332 | if [catch {
|
|---|
| 333 | tqsPuts 2 [tqsDisplay "Notify $p - $req" 65]
|
|---|
| 334 | puts -nonewline $p $msg
|
|---|
| 335 | #flush $p
|
|---|
| 336 | } error] {
|
|---|
| 337 | tqsPuts 1 "Notify to $p failed for $view $key"
|
|---|
| 338 | tqsPuts 1 " Reason: $error"
|
|---|
| 339 | catch {close $p}
|
|---|
| 340 | tqsUnsubscribe $p
|
|---|
| 341 | }
|
|---|
| 342 | }
|
|---|
| 343 | }
|
|---|
| 344 |
|
|---|
| 345 | if {![info exists tqs_info(pending)] &&
|
|---|
| 346 | [info exists tqs_info(timeout)]} {
|
|---|
| 347 | set tqs_info(pending) [after $tqs_info(timeout) TqsCommit]
|
|---|
| 348 | }
|
|---|
| 349 | }
|
|---|
| 350 |
|
|---|
| 351 | # called whenever a request comes in
|
|---|
| 352 | proc tqsRequest {sock} {
|
|---|
| 353 | global tqs_info
|
|---|
| 354 |
|
|---|
| 355 | if {[gets $sock bytes] > 0} {
|
|---|
| 356 | set request [read $sock [lindex $bytes 0]]
|
|---|
| 357 | if ![eof $sock] {
|
|---|
| 358 | # debugging: incoming request
|
|---|
| 359 | tqsPuts 1 [tqsDisplay " $request" 65]
|
|---|
| 360 |
|
|---|
| 361 | set tqs_info(port) $sock
|
|---|
| 362 |
|
|---|
| 363 | set err [catch {uplevel #0 Tqs$request} reply]
|
|---|
| 364 | set msg [list Reply $err $reply]
|
|---|
| 365 | puts -nonewline $sock "[string length $msg]\n$msg"
|
|---|
| 366 |
|
|---|
| 367 | # debugging: returned results
|
|---|
| 368 | if {[string length $reply] > 0} {
|
|---|
| 369 | tqsPuts 3 " result: [tqsDisplay $reply 54]"
|
|---|
| 370 | }
|
|---|
| 371 |
|
|---|
| 372 | #flush $sock
|
|---|
| 373 | return
|
|---|
| 374 | }
|
|---|
| 375 | }
|
|---|
| 376 |
|
|---|
| 377 | tqsPuts 1 "Closing $sock"
|
|---|
| 378 | close $sock
|
|---|
| 379 | tqsUnsubscribe $sock
|
|---|
| 380 | }
|
|---|
| 381 |
|
|---|
| 382 | # called whenever a connection is opened
|
|---|
| 383 | proc tqsAccept {sock addr port} {
|
|---|
| 384 | global tqs_info
|
|---|
| 385 | fconfigure $sock -translation binary -buffering none
|
|---|
| 386 | fileevent $sock readable [list tqsRequest $sock]
|
|---|
| 387 | }
|
|---|
| 388 |
|
|---|
| 389 | # this can be called to start a background server
|
|---|
| 390 | proc tqsStart {port} {
|
|---|
| 391 | global tqs_notify tqs_external
|
|---|
| 392 |
|
|---|
| 393 | array set tqs_notify {}
|
|---|
| 394 |
|
|---|
| 395 | foreach x [glob -nocomplain *.data] {
|
|---|
| 396 | regsub {\.data$} $x {} x
|
|---|
| 397 | set tqs_external($x) ""
|
|---|
| 398 | }
|
|---|
| 399 |
|
|---|
| 400 | socket -server tqsAccept $port
|
|---|
| 401 | }
|
|---|
| 402 |
|
|---|
| 403 | # this wraps the server into a standalone, it runs until shutdown
|
|---|
| 404 | proc tqsRun {port} {
|
|---|
| 405 | global tqs_info
|
|---|
| 406 |
|
|---|
| 407 | set tqs_info(shutdown) [clock seconds]
|
|---|
| 408 |
|
|---|
| 409 | # these status messages are not disabled if verbose is off
|
|---|
| 410 | puts "Tequila server on port $port started."
|
|---|
| 411 | tqsStart $port
|
|---|
| 412 | vwait tqs_info(shutdown)
|
|---|
| 413 | puts "Tequila server on port $port has been shut down."
|
|---|
| 414 | }
|
|---|
| 415 |
|
|---|
| 416 | # client-callable: terminate a server started with "tqsRun"
|
|---|
| 417 | proc TqsShutdown {} {
|
|---|
| 418 | global tqs_info
|
|---|
| 419 |
|
|---|
| 420 | # returns number of seconds since the server was started
|
|---|
| 421 | # main effect is setting tqs_info(shutdown), which ends vwait
|
|---|
| 422 | set tqs_info(shutdown) [expr {[clock seconds]-$tqs_info(shutdown)}]
|
|---|
| 423 | }
|
|---|
| 424 |
|
|---|
| 425 | # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|---|
| 426 | # This script can be used standalone, in which case the code below will
|
|---|
| 427 | # be run, or as part of a scripted document, which expects a "package
|
|---|
| 428 | # ifneeded tequilas ..." to have been set up. In that case, the code
|
|---|
| 429 | # below will not be executed, allowing the caller so set up different
|
|---|
| 430 | # parameter values before calling tqsRun or tqsStart (background use).
|
|---|
| 431 | # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|---|
| 432 |
|
|---|
| 433 | if {0 && [lsearch -exact [package names] tequilas] < 0} {
|
|---|
| 434 | package require Mk4tcl
|
|---|
| 435 | mk::file open tqs tequilas.dat -nocommit
|
|---|
| 436 |
|
|---|
| 437 | set tqs_info(verbose) 0 ;# default logging is off
|
|---|
| 438 | TqsTimer 30000 ;# default commit timer is 30 seconds
|
|---|
| 439 | tqsRun 20458 ;# default port is 20458
|
|---|
| 440 | }
|
|---|
| 441 |
|
|---|
| 442 | package provide tequilas 1.5
|
|---|
