4 # c/$conn(super) 0 or 1
6 # [msel/$conn "$msg "] 0 or 1
7 # [mreplay/$conn "$msg "] 0 or 1 during replay only
8 # c/$conn(q) [list $inputline ...]
11 # $queueing [list $conn ...]
13 # $permissions [list allow|super|deny $ipaddrhex $maskhex ...]
15 # $realtime_retry [list $timeoutid $awaitedpongmsg|{} $buf]
16 # $realtime_last_retries [list $now $now $now ... $now]
17 # $replay("$pri $key") $rhs $pri is \d\d; causes replay of "$key $rhs"
18 # $detect0($seg) unset -> 1 or irrelevant; [after ...]
21 # configs set directly in multiplex-config:
22 # $records [list filename.record ...]
25 # $conn is in $queueing iff c/$conn(q) is nonempty
27 # globals relating to realtime's command execution state:
28 # awaiting awaiting executing global
29 # idle executing/nak ack internal cmd dead
31 # $realtime set set set ? unset
32 # $currentcmd unset $cmd $cmd $cmd unset
33 # $currentconn unset $conn or {} $conn or {} $conn unset
34 # $executing 0 0 1 2 0
36 # globals relating to realtime start/stop:
37 # manual ready to running awaiting off
38 # $realtime any unset set unset
39 # $realtime_retry unset {} {} [list ...]
41 # realtime_last_retries is unset at startup, and becomes unset when we
42 # enter auto mode. unset means in auto mode we have to set it.
43 # It contains the last few startup times.
45 # replay priorities and messages:
47 # 40 warning realtime-failed
48 # 41 warning save-dump-failed
54 # picio out polarity ...
58 catch { set libdir $env(TRAINS_HOSTSIDE) }
59 source $libdir/lib.tcl
61 #---------- replay, general utilities, etc. ----------
63 proc compile-glob-patterns {pats procname} {
64 if {[llength $pats] > 20 || [string length $pats] > 200} {
65 cmderr LimitExceeded "too many, or too long, patterns"
68 append def " switch -regexp -- \$m {\n"
70 set neg [regsub {^~} $pat {} pat]
71 if {[regexp {[^-+./&|:=0-9a-zA-Z_*?]} $pat]} {
72 cmderr BadCmd "pattern contains invalid character"
74 regsub -all {[-+./&|:=]} $pat {\\&} pat
75 regsub -all {_} $pat {\s+} pat
76 regsub -all {\*} $pat {\S+} pat
77 regsub -all {\?} $pat {.} pat
79 append def " [list ^$pat " return [expr {!$neg}] "]\n"
81 append def { {^[-&]\S|^\+debug\s} { return 0 }} "\n"
83 append def " return 1\n"
84 proc $procname {m} $def
87 proc nargs {l {n 0}} {
88 if {[llength $l]!=$n} { cmderr BadCmd "wrong number of arguments" }
91 proc cmderr {ecode emsg} { error $emsg "" [list TRAIN CMDERR $ecode] }
97 {^\<[<&] picioh (?:in msg|out) 8[89a-f]|^\<[<&] picio (?:in pong|out ping)} \
103 proc xmit-relevantly {m {tlog 0}} {
104 global executing currentconn conns
106 puts "@[clock format [clock seconds] -format {%Y-%m-%d %T %Z}] $m"
110 set myconn $currentconn
111 if {[string length $currentconn]} {
112 trapping xmit-only-noreport $currentconn +$m
120 foreach conn [array names conns] {
121 if {[string compare $myconn $conn]} {
122 trapping xmit-only-noreport $conn $othersm
127 proc xmit-relevantly-savereplay {pri key rhs {tlog 0}} {
129 upvar #0 replay($pk) rep
131 xmit-relevantly "$key $rhs" $tlog
134 proc savereplay-clear {pk} {
135 upvar #0 replay($pk) rep; catch { unset rep }
138 proc savereplay-clear-re {re} { # re is anchored at start
140 if {![info exists replay]} return
141 foreach pk [array names replay] {
142 if {[regexp -- ^$re "$pk "]} { unset replay($pk) }
146 proc save-dump-failed-warn {fpre howpre emsg} {
148 switch -glob $errorCode {
150 set k [lindex $errorCode 1]
151 set m [lindex $errorCode 2]
152 xmit-relevantly-savereplay 41 \
153 "warning save-dump-failed" "$fpre$k : $howpre$m"
156 xmit-relevantly-savereplay 41 \
157 "warning save-dump-failed" "$fpre: $emsg"
165 savereplay-clear "41 warning save-dump-failed"
166 savereplay-clear "42 info save-dump"
168 set now [clock seconds]
169 set now [clock format $now -format %Y-%m-%dT%H-%M-%S%z]
170 set dumpdir +dump.$now
175 save-dump-failed-warn "" "mkdir $dumpdir: " $emsg
176 error $emsg "" {TRAIN REPORTED}
181 +persist.data +persist.data.new +persist.data.old
182 +persist.conv +persist.conv.new +persist.conv.old
184 if {[catch { link $f $dumpdir/$f } emsg]} {
185 switch -glob $errorCode {
187 * { save-dump-failed-warn "$f " "link $f $dumpdir/: " $emsg }
191 xmit-relevantly-savereplay 42 "info save-dump" "$dumpdir" 1
194 #---------- multiplexer-implemented command ----------
196 proc local/select {conn args} {
198 compile-glob-patterns $args msel/$conn
201 proc global/!save-dump {conn args} {
203 if {[catch { save-dump } emsg]} {
204 cmderr HostSupportSystemsProblem "failed to save dump: $emsg"
208 proc do-replay {conn} {
210 foreach pk [lsort [array names replay]] {
211 set pri [string range $pk 0 2]
212 set lhs [string range $pk 3 end]
213 set r [string trimright $replay($pk) "\n"]
214 foreach m [split $r "\n"] {
215 puts "<$conn|$pri|$lhs $m"
216 xmit-only-noreport $conn "|$lhs $m"
221 proc local/replay {conn args} {
222 if {[llength $args]} {
223 rename msel/$conn mreplay/$conn ;# park it here for a moment
224 compile-glob-patterns $args msel/$conn
227 if {[llength $args]} {
229 rename mreplay/$conn msel/$conn
233 proc local/select-replay {conn args} {
235 compile-glob-patterns $args msel/$conn
239 #---------- automatic realtime restart ----------
241 proc global/!realtime {conn args} {
242 global realtime realtime_retry realtime_last_retries
244 set how [lindex $args 0]
246 # perhaps kill the running instance
247 # this switch also checks the argument
248 switch -exact -- $how {
249 kill - stop - restart - start - start-manual {
250 if {[info exists realtime]} {
251 realtime-failed killed "termination requested by command"
257 cmderr BadCmd "unknown !realtime subcommand"
261 # set the operating mode
262 switch -exact -- $how {
265 set realtime_retry {}
266 catch { unset realtime_last_retries }
268 stop - start - start-manual {
270 catch { unset realtime_retry }
274 # (re)start if applicable
275 switch -exact -- $how {
283 after idle realtime-retry-check
288 proc realtime-retry-reset {} {
289 global realtime_retry serchan
290 if {![info exists realtime_retry]} return
291 if {![llength $realtime_retry]} return
292 manyset $realtime_retry timeoutid
293 fileevent $serchan readable {}
294 after cancel $timeoutid
295 set realtime_retry {}
298 proc realtime-retry-check {} {
299 global realtime_retry realtime
300 global realtime_last_retries restart_min_mean_interval
301 if {![info exists realtime_retry]} return
302 if {[llength $realtime_retry]} return
303 if {[info exists realtime]} return
305 if {![info exists realtime_last_retries]} {
306 set realtime_last_retries {0 0 0 0 0}
308 set oldest [lindex $realtime_last_retries 0]
309 set now [clock seconds]
311 $restart_min_mean_interval * [llength $realtime_last_retries]} {
312 xmit-relevantly-savereplay 40 \
313 "warning realtime-failed" looping-disabled
317 set realtime_last_retries [lrange $realtime_last_retries 1 end]
318 lappend realtime_last_retries $now
323 proc realtime-retry-realtime-failed {} {
324 global realtime_retry serchan
325 if {![info exists realtime_retry]} return
326 if {[llength $realtime_retry]} { error "huh? $realtime_retry" }
327 fileevent $serchan readable realtime-retry-serchan-readable
328 set after [after 500 realtime-retry-send-ping]
329 set realtime_retry [list $after {} {}]
332 proc realtime-retry-send-ping {} {
333 global realtime_retry urandom serchan
334 manyset $realtime_retry after pong buf
335 set x [read $urandom 2]
337 if {[string length $x] != 4} { error "urandom short read `$x'" }
338 set x [expr "0x$x & 0x077f"]
339 set ping [format %04x [expr {0x8800 ^ $x}]]
340 set pong [format %04x [expr {0x885a ^ $x}]]
341 #puts "<! picioh out await-off $pong (await $pong)"
342 puts -nonewline $serchan [binary format H* $ping]
343 set after [after 700 realtime-retry-now-off]
344 set realtime_retry [list $after $pong {}]
347 proc realtime-retry-serchan-readable {} {
348 global realtime_retry serchan
349 manyset $realtime_retry after pong buf
350 set x [read $serchan]
352 #puts "<! picioh in await-off $x"
353 if {![string length $x] && [eof $serchan]} { error "eof on serial port" }
355 while {[regexp {^((?:[89a-f].)*[0-7].)(.*)$} $buf dummy msg buf]} {
356 if {![string compare 09 $msg]} {
357 realtime-retry-now-off
360 if {![string compare $pong $msg]} {
362 set after [after 200 realtime-retry-send-ping]
363 set realtime_retry [list $after {} {}]
367 set realtime_retry [list $after $pong $buf]
370 proc realtime-retry-now-off {} {
375 #---------- connection and commands ----------
377 proc client-inputline {conn l} {
381 client-disable-readable $conn
382 if {![llength $c(q)]} { lappend queueing $conn }
384 after idle process-queues
387 proc process-queues {} {
388 global queueing currentcmd
389 while {![info exists currentcmd] && [llength $queueing]} {
390 set conn [lindex $queueing 0]
391 set queueing [lrange $queueing 1 end]
394 if {![llength $c(q)]} continue
396 set l [lindex $c(q) 0]
397 set c(q) [lrange $c(q) 1 end]
398 if {[llength $c(q)]} {
399 lappend queueing $conn
401 client-enable-readable $conn
404 trapping process-command $conn $l
408 proc process-command {conn l} {
409 global currentcmd currentconn realtime executing
410 global errorInfo errorCode
414 if {[regexp {^#} $l]} return; # comments ?! ok then ...
415 set l [string trim $l]
416 if {![string length $l]} return
417 if {![regexp {^((!?)[-+a-z0-9]+)(?:\s.*)?$} $l dummy cmd priv]} {
418 error "improper command name" {} {TRAIN CMDNAK BadCmd}
420 if {[regexp {[^ \t!-~]} $l]} {
421 error "improper character" {} {TRAIN CMDNAK BadCmd}
423 if {[string length $priv] && !$c(super)} {
424 error "" {} {TRAIN CMDNAK PermissionDenied}
427 if {![catch { info args global/$cmd }]} {
429 set currentconn $conn
431 xmit-relevantly "executing $cmd"
432 eval [list global/$cmd $conn] [lrange [split $l] 1 end]
433 } elseif {![catch { info args local/$cmd }]} {
434 xmit-only $conn "+executing $cmd"
435 eval [list local/$cmd $conn] [lrange [split $l] 1 end]
436 } elseif {![info exists realtime]} {
437 error "" {} {TRAIN CMDNAK realtime-not-running}
440 set currentconn $conn
445 if {[string match {POSIX EPIPE *} $errorCode]} {
446 realtime-failed EPIPE ""
447 } elseif {[string match {POSIX *} $errorCode]} {
448 realtime-failed [lindex $errorCode 1] \
449 "write failed: [lindex $errorCode 2]"
451 realtime-failed ?write-[lindex $errorCode 0] \
452 "puts failed ($errorCode): $emsg"
471 switch -glob $errorCode {
475 set el [concat [list +nack] [lrange $errorCode 2 end]]
476 if {[string length $emsg]} { append el ": " $emsg }
477 xmit-only $conn "$el"
480 set el [concat [list +ack $cmd] [lrange $errorCode 2 end]]
481 xmit-only $conn "$el : $emsg"
483 catch { unset currentconn }
484 catch { unset currentcmd }
487 set ei $errorInfo; set ec $errorCode
494 proc client-eof {conn} {
499 proc client-enable-readable {conn} {
500 fileevent $conn readable [list trapping readable client $conn]
502 proc client-disable-readable {conn} {
503 fileevent $conn readable {}
506 #---------- general IO ----------
508 proc xmit-puts {conn msg} {
509 global conns errorInfo
510 if {![info exists conns($conn)]} return
511 if {[catch { puts -nonewline $conn $msg } emsg]} {
512 kill-conn $conn "=failed client-io : $emsg"
513 error $emsg $errorInfo {TRAIN REPORTED}
517 proc xmit-only-always {conn msg} {
519 xmit-puts $conn "$msg\n"
521 proc xmit-only-noreport {conn msg} {
523 if {[msel/$conn $msg]} { xmit-puts $conn $msg }
525 proc xmit-only {conn msg} {
526 xmit-only-noreport $conn $msg
529 #---------- error handling ----------
531 proc kill-conn {conn msg} {
532 global conns queueing currentconn
534 catch { unset conns($conn) } ;# do this first to stop any recursion
535 if {[info exists currentconn]} {
536 if {![string compare $currentconn $conn]} { set currentconn {} }
538 puts "<$conn\$ closing : $msg"
539 if {[string length $msg]} { catch { xmit-only-always $conn "$msg" } }
540 catch { close $conn }
541 if {[set ix [lsearch -exact $queueing $conn]] >= 0} {
542 set queueing [lreplace $queueing $ix $ix]
545 catch { rename msel/$conn {} }
546 catch { rename mreplay/$conn {} }
551 proc report-unexpected {headmsg emsg} {
553 global errorInfo errorCode
555 "========== $headmsg ==========\n
559 ========================================\n"
563 proc bgerror {emsg} {
564 global errorInfo errorCode
565 catch { report-unexpected {UNEXPECTED UNTRAPPED ERROR} $emsg }
569 proc kill-conn-ierr {conn} {
570 kill-conn $conn "=failed : Internal error"
573 proc trapping {proc conn args} {
574 global errorInfo errorCode
575 if {![catch { uplevel #0 [list $proc $conn] $args } r]} { return $r }
576 switch -glob $errorCode {
577 {TRAIN EXPECTED*} { kill-conn $conn "=failed : $r" }
578 {TRAIN REPORTED*} { kill-conn $conn "" }
580 report-unexpected {UNEXPECTED ERROR} $r
586 #---------- realtime subprocess ----------
588 proc realtime-failed {k m} {
589 global realtime currentcmd currentconn executing
590 global errorInfo errorCode replay
591 # if $m is "", use wait status
592 if {![string length $m]} {
594 fconfigure $realtime -blocking 1
598 set m "unexpectedly closed pipe ?!"
600 } elseif {[string match {CHILDSTATUS*} $errorCode]} {
601 set m "exited with status [lindex $errorCode 2]"
602 set k "exit[lindex $errorCode 2]"
603 } elseif {[string match {CHILDKILLED*} $errorCode]} {
604 set m "killed by signal [lindex $errorCode 3]"
605 set k [lindex $errorCode 2]
607 set m "failed confusingly ($errorCode): $emsg"
608 set k ?wait-[lindex $errorCode 0]
611 catch { close $realtime }
614 catch { unset realtime }
616 set sef [open +realtime.stderr r]
617 while {[gets $sef l] >= 0} {
618 xmit-relevantly-savereplay 40 \
619 "warning realtime-failed stderr" ": $l"
624 if {![string match {POSIX ENOENT *} $errorCode]} {
625 xmit-relevantly-savereplay 40 \
626 "warning realtime-failed stderr" "unreadable : $emsg"
630 xmit-relevantly-savereplay 40 \
631 "warning realtime-failed" "reason $k : $m"
634 # internal commands need to deal with it themselves
635 } elseif {$executing} {
636 xmit-relevantly "ack $currentcmd SystemFailed realtime : $m"
638 } elseif {[info exists currentcmd]} {
639 xmit-relevantly "nak SystemFailed realtime : $m"
644 realtime-retry-realtime-failed
647 proc realtime-notrunning {} {
648 xmit-relevantly-savereplay 10 stastate Crashed
651 proc realtime-start {xopts} {
652 global realtime records realtime_xopts dev_railway libdir
653 if {[info exists realtime]} { error "realtime already running" }
656 [list 2> +realtime.stderr $libdir/realtime -v2 -s$dev_railway] \
657 $realtime_xopts $xopts]
658 foreach f $records { lappend cl $libdir/$f }
660 savereplay-clear-re "40 warning realtime-failed"
662 set realtime [open |$cl r+]
663 fconfigure $realtime -translation binary -buffering line -blocking 0
664 fileevent $realtime readable [list readable realtime $realtime]
666 realtime-failed start $emsg
667 error "realtime failed : $emsg" "" {TRAIN REPORTED}
671 proc realtime-eof {dummy} { realtime-failed EOF "" }
673 proc detect0timeout {seg} {
675 upvar #0 detect0($seg) d0
677 set key "detect $seg"
680 xmit-relevantly "$key 0"
683 proc clear-replay-detects {} {
685 foreach k [array names replay] {
686 if {[regexp {^.. detect } $k]} { unset replay($k) }
690 proc realtime-inputline {dummy l} {
691 global detectlag replay testmode
692 global executing currentcmd currentconn
694 if {$testmode && [regexp {^%(.*)} $l dummy rhs]} {
695 set r [catch { uplevel #0 $rhs } emsg]
696 if {$r} { puts "** $emsg\n" } else { puts "=> $emsg\n" }
703 if {[regexp {^(detect (\w+)) ([01])$} $l dummy key seg value]} {
704 upvar #0 detect0($seg) d0
705 catch { after cancel $d0 }
707 if {[info exists d0]} { unset d0; return }
709 set d0 [after $detectlag detect0timeout $seg]
713 } elseif {[regexp {^(stastate) (.*)$} $l dummy key value]} {
714 switch -exact -- $value {
717 savereplay-clear-re {^60 train \S+ speed }
720 savereplay-clear-re {^50 resolution }
721 savereplay-clear-re {^60 train \S+ (?:at|has) }
722 savereplay-clear-re {^60 movpos }
727 } elseif {[regexp {^(resolution) (.*)$} $l dummy key addvalue]} {
729 } elseif {[regexp {^(picio out) (on|off)$} $l dummy key value]} {
731 } elseif {[regexp -expanded {
732 ^( movpos \s \S+ \s (?: feat \s \S+ | position) |
733 train \s \S+ \s (?: has | at | speed \s commanding ) |
734 picio \s out \s polarity
736 } $l dummy key value]} {
739 if {[info exists key]} {
741 upvar #0 replay($pk) rep
742 if {[info exists value]} {
745 append rep $addvalue "\n"
749 switch -regexp -- $l {
750 {^executing\s|^nak\s} {
755 xmit-relevantly $l $tlog
757 switch -regexp -- $l {
762 after idle process-queues
767 #---------- new connections ----------
769 proc find-permission {ipaddr} {
771 set ipaddr [ipaddr2hex $ipaddr]
772 foreach {keyword paddr pmask} $permissions {
773 if {[expr {($ipaddr & $pmask) == $paddr}]} { return $keyword }
778 proc connected {conn} {
781 fconfig-trainproto $conn
784 set perm [find-permission $c(ipaddr)]
785 switch -exact $perm {
786 deny { kill-conn $conn =denied; return }
787 allow { set c(super) 0 }
788 super { set c(super) 1 }
789 default { error "$perm ?" }
791 compile-glob-patterns {?info ?warning} msel/$conn
793 xmit-only-always $conn =connected
794 xmit-only-always $conn "=permission [lindex {normal super} $c(super)]"
795 client-enable-readable $conn
798 proc newconn {conn ipaddr port} {
801 puts "$conn new-client $conn $ipaddr,$port"
802 set c(ipaddr) $ipaddr
803 trapping connected $conn
806 proc try-bind {addr} {
807 global master errorInfo errorCode port
809 set master [socket -server newconn -myaddr $addr $port]
810 } emsg]} { return 1 }
811 if {[string match {POSIX EADDRNOTAVAIL *} $errorCode]} { return 0 }
812 error $emsg $errorInfo $errorCode
815 proc ipaddr2hex {addr} {
816 if {![regexp {^\d+\.\d+\.\d+\.\d+$} $addr]} {
817 error "invalid ip address $addr"
820 foreach octet [split $addr .] { append val [format %02x $octet] }
821 if {[string length $val] != 10} {
822 error "invalid numbers in ip address $addr (calculated $val ?!)"
827 proc binding {addr blist} {
828 global master permissions port
829 if {[info exists master]} return
830 if {![try-bind $addr]} return
831 puts "bound to $addr,$port"
833 foreach {keyword pattern} $blist {
834 switch -exact $keyword allow - super - deny { } \
835 default { error "unknown binding keyword $keyword" }
836 if {![regexp {^(.*)/(\d+)$} $pattern dummy host masklen]} {
837 set host $pattern; set masklen 32
839 set ipaddr [ipaddr2hex $host]
840 set mask [expr {$masklen==0 ? 0 : 0xffffffff << (32-$masklen)}]
841 set mask [format %#10x $mask]
842 if {$ipaddr & ~$mask} {
843 error "non-zero bits outside mask in $pattern ($ipaddr/$mask)"
845 lappend permissions $keyword $ipaddr $mask
850 global queueing executing testmode realtime port urandom serchan
851 global dev_railway libdir lputs
852 catch { close $master }; catch { unset master }
854 setting testmode 0 {[01]}
855 setting lputs 0 {[01]}
856 setting dev_railway {} {/.*}
857 setting restart_min_mean_interval 5 {^\d+}
858 setting realtime_xopts {} {.*}
861 uplevel #0 source $libdir/multiplex-config
865 set urandom [open /dev/urandom r]
866 fconfigure $urandom -buffering none -translation binary
868 set serchan [open $dev_railway {RDWR NOCTTY NONBLOCK}]
869 fconfigure $serchan -translation binary -buffering none -blocking 0
875 after idle realtime-retry-check
877 fconfig-trainproto stdin
878 fconfig-trainproto stdout
879 fileevent stdin readable [list readable realtime stdin]