hostside/multiplex

   1 #!/usr/bin/tcl
   2
   3 # per connection:
   4 #    c/$conn(super)          0 or 1
   5 #    c/$conn(ipaddr)
   6 #    [msel/$conn "$msg "]    0 or 1
   7 #    [mreplay/$conn "$msg "] 0 or 1 during replay only
   8 #    c/$conn(q)              [list $inputline ...]
   9 #
  10 # globals:
  11 #    $queueing            [list $conn ...]
  12 #    $master              socket
  13 #    $permissions         [list allow|super|deny $ipaddrhex $maskhex ...]
  14 #    $realtime            pipes
  15 #    $realtime_retry      [list $timeoutid $awaitedpongmsg|{} $buf]
  16 #    $replay("$pri $key") $rhs     $pri is \d\d; causes replay of  "$key $rhs"
  17 #    $detect0($seg)       unset -> 1 or irrelevant; [after ...]
  18 #    $conns($conn)        1
  19 #
  20 # configs set directly in multiplex-config:
  21 #    $records          [list filename.record ...]
  22 #    $detectlag        <ms>
  23 #
  24 # $conn is in $queueing iff c/$conn(q) is nonempty
  25 #
  26 # globals relating to realtime's command execution state:
  27 #                           awaiting        awaiting  executing global
  28 #                   idle     executing/nak   ack       internal cmd     dead
  29 #
  30 #    $realtime       set      set            set          ?             unset
  31 #    $currentcmd     unset    $cmd           $cmd         $cmd          unset
  32 #    $currentconn    unset    $conn or {}    $conn or {}  $conn         unset
  33 #    $executing      0        0              1            2             0
  34 #
  35 # globals relating to realtime start/stop:
  36 #                     manual      ready to   running   awaiting off
  37 #    $realtime         any          unset      set       unset
  38 #    $realtime_retry   unset        {}         {}        [list ...]
  39 #
  40 # replay priorities and messages:
  41 #    10 stastate
  42 #    40 warning realtime-failed
  43 #    41 warning save-dump-failed
  44 #    42 info save-dump
  45 #    50 resolution ....
  46 #    55 picio out on|off
  47 #    60 movpos ...
  48 #       train ...
  49 #       picio out polarity ...
  50 #    70 detect <seg> 0|1
  51
  52 set libdir .
  53 catch { set libdir $env(TRAINS_HOSTSIDE) }
  54 source $libdir/lib.tcl
  55
  56 #---------- replay, general utilities, etc. ----------
  57
  58 proc compile-glob-patterns {pats procname} {
  59     if {[llength $pats] > 20 || [string length $pats] > 200} {
  60         cmderr LimitExceeded "too many, or too long, patterns"
  61     }
  62     set def "\n"
  63     append def "    switch -regexp -- \$m {\n"
  64     foreach pat $pats {
  65         set neg [regsub {^~} $pat {} pat]
  66         if {[regexp {[^-+./&|:=0-9a-zA-Z_*?]} $pat]} {
  67             cmderr BadCmd "pattern contains invalid character"
  68         }
  69         regsub -all {[-+./&|:=]} $pat {\\&} pat
  70         regsub -all {_} $pat {\s+} pat
  71         regsub -all {\*} $pat {\S+} pat
  72         regsub -all {\?} $pat {.} pat
  73         append pat {\s}
  74         append def "    [list ^$pat " return [expr {!$neg}] "]\n"
  75     }
  76     append def {    {^[-&]\S|^\+debug\s} { return 0 }} "\n"
  77     append def "    }\n"
  78     append def "    return 1\n"
  79     proc $procname {m} $def
  80 }
  81
  82 proc nargs {l {n 0}} {
  83     if {[llength $l]!=$n} { cmderr BadCmd "wrong number of arguments" }
  84 }
  85
  86 proc cmderr {ecode emsg} { error $emsg "" [list TRAIN CMDERR $ecode] }
  87
  88 proc lputs {m} {
  89     global lputs
  90     if {!$lputs} return
  91     if {[regexp \
  92  {^\<[<&] picioh (?:in msg|out) 8[89a-f]|^\<[<&] picio (?:in pong|out ping)} \
  93             $m]} \
  94         return
  95     puts $m
  96 }
  97
  98 proc xmit-relevantly {m {tlog 0}} {
  99     global executing currentconn conns
 100     if {$tlog} {
 101         puts "@[clock format [clock seconds] -format {%Y-%m-%d %T %Z}] $m"
 102     }
 103     if {$executing} {
 104         puts "<* $m"
 105         set myconn $currentconn
 106         if {[string length $currentconn]} {
 107             trapping xmit-only-noreport $currentconn +$m
 108         }
 109         set othersm -$m
 110     } else {
 111         lputs "<& $m"
 112         set myconn {}
 113         set othersm &$m
 114     }
 115     foreach conn [array names conns] {
 116         if {[string compare $myconn $conn]} {
 117             trapping xmit-only-noreport $conn $othersm
 118         }
 119     }
 120 }
 121
 122 proc xmit-relevantly-savereplay {pri key rhs {tlog 0}} {
 123     set pk "$pri $key"
 124     upvar #0 replay($pk) rep
 125     set rep $rhs
 126     xmit-relevantly "$key $rhs" $tlog
 127 }
 128
 129 proc savereplay-clear {pk} {
 130     upvar #0 replay($pk) rep; catch { unset rep }
 131 }
 132
 133 proc savereplay-clear-re {re} { # re is anchored at start
 134     global replay
 135     if {![info exists replay]} return
 136     foreach pk [array names replay] {
 137         if {[regexp -- ^$re "$pk "]} { unset replay($pk) }
 138     }
 139 }
 140
 141 proc save-dump-failed-warn {fpre howpre emsg} {
 142     global errorCode
 143     switch -glob $errorCode {
 144         {POSIX *} {
 145             set k [lindex $errorCode 1]
 146             set m [lindex $errorCode 2]
 147             xmit-relevantly-savereplay 41 \
 148                     "warning save-dump-failed" "$fpre$k : $howpre$m"
 149         }
 150         * {
 151             xmit-relevantly-savereplay 41 \
 152                     "warning save-dump-failed" "$fpre: $emsg"
 153         }
 154     }
 155 }
 156
 157 proc save-dump {} {
 158     global errorCode
 159
 160     savereplay-clear "41 warning save-dump-failed"
 161     savereplay-clear "42 info save-dump"
 162
 163     set now [clock seconds]
 164     set now [clock format $now -format %Y-%m-%dT%H-%M-%S%z]
 165     set dumpdir +dump.$now
 166
 167     if {[catch {
 168         file mkdir $dumpdir
 169     } emsg]} {
 170         save-dump-failed-warn "" "mkdir $dumpdir: " $emsg
 171         error $emsg "" {TRAIN REPORTED}
 172     }
 173
 174     foreach f {
 175         +realtime.log
 176         +persist.data +persist.data.new +persist.data.old
 177         +persist.conv +persist.conv.new +persist.conv.old
 178     } {
 179         if {[catch { link $f $dumpdir/$f } emsg]} {
 180             switch -glob $errorCode {
 181                 {POSIX ENOENT *} { }
 182                 * { save-dump-failed-warn "$f " "link $f $dumpdir/: " $emsg }
 183             }
 184         }
 185     }
 186     xmit-relevantly-savereplay 42 "info save-dump" "$dumpdir" 1
 187 }
 188
 189 #---------- multiplexer-implemented command ----------
 190
 191 proc local/select {conn args} {
 192     upvar #0 c/$conn c
 193     compile-glob-patterns $args msel/$conn
 194 }
 195
 196 proc global/!save-dump {conn args} {
 197     nargs $args
 198     if {[catch { save-dump } emsg]} {
 199         cmderr HostSupportSystemsProblem "failed to save dump: $emsg"
 200     }
 201 }
 202
 203 proc do-replay {conn} {
 204     global replay
 205     foreach pk [lsort [array names replay]] {
 206         set pri [string range $pk 0 2]
 207         set lhs [string range $pk 3 end]
 208         set r [string trimright $replay($pk) "\n"]
 209         foreach m [split $r "\n"] {
 210             puts "<$conn|$pri|$lhs $m"
 211             xmit-only-noreport $conn "|$lhs $m"
 212         }
 213     }
 214 }
 215
 216 proc local/replay {conn args} {
 217     if {[llength $args]} {
 218         rename msel/$conn mreplay/$conn ;# park it here for a moment
 219         compile-glob-patterns $args msel/$conn
 220     }
 221     do-replay $conn
 222     if {[llength $args]} {
 223         rename msel/$conn {}
 224         rename mreplay/$conn msel/$conn
 225     }
 226 }
 227
 228 proc local/select-replay {conn args} {
 229     upvar #0 c/$conn c
 230     compile-glob-patterns $args msel/$conn
 231     do-replay $conn
 232 }
 233
 234 #---------- automatic realtime restart ----------
 235
 236 proc global/!realtime {conn args} {
 237     global realtime realtime_retry
 238     nargs $args 1
 239     set how [lindex $args 0]
 240
 241     # perhaps kill the running instance
 242     # this switch also checks the argument
 243     switch -exact -- $how {
 244         kill - stop - restart - start - start-manual {
 245             if {[info exists realtime]} {
 246                 realtime-failed killed "termination requested by command"
 247             }
 248         }
 249         auto {
 250         }
 251         default {
 252             cmderr BadCmd "unknown !realtime subcommand"
 253         }
 254     }
 255
 256     # set the operating mode
 257     switch -exact -- $how {
 258         auto {
 259             realtime-retry-reset
 260             set realtime_retry {}
 261         }
 262         stop - start - start-manual {
 263             realtime-retry-reset
 264             catch { unset realtime_retry }
 265         }
 266     }
 267
 268     # (re)start if applicable
 269     switch -exact -- $how {
 270         start - restart {
 271             realtime-start {}
 272         }
 273         start-manual {
 274             realtime-start -m
 275         }
 276         default {
 277             after idle realtime-retry-check
 278         }
 279     }
 280 }
 281
 282 proc realtime-retry-reset {} {
 283     global realtime_retry serchan
 284     if {![info exists realtime_retry]} return
 285     if {![llength $realtime_retry]} return
 286     manyset $realtime_retry timeoutid
 287     fileevent $serchan readable {}
 288     after cancel $timeoutid
 289     set realtime_retry {}
 290 }
 291
 292 proc realtime-retry-check {} {
 293     global realtime_retry realtime
 294     if {![info exists realtime_retry]} return
 295     if {[llength $realtime_retry]} return
 296     if {[info exists realtime]} return
 297     realtime-start {}
 298 }
 299
 300 proc realtime-retry-realtime-failed {} {
 301     global realtime_retry serchan
 302     if {![info exists realtime_retry]} return
 303     if {[llength $realtime_retry]} { error "huh? $realtime_retry" }
 304     fileevent $serchan readable realtime-retry-serchan-readable
 305     set after [after 500 realtime-retry-send-ping]
 306     set realtime_retry [list $after {} {}]
 307 }
 308
 309 proc realtime-retry-send-ping {} {
 310     global realtime_retry urandom serchan
 311     manyset $realtime_retry after pong buf
 312     set x [read $urandom 2]
 313     binary scan $x H* x
 314     if {[string length $x] != 4} { error "urandom short read `$x'" }
 315     set x [expr "0x$x & 0x077f"]
 316     set ping [format %04x [expr {0x8800 ^ $x}]]
 317     set pong [format %04x [expr {0x885a ^ $x}]]
 318     #puts "<! picioh out await-off $pong  (await $pong)"
 319     puts -nonewline $serchan [binary format H* $ping]
 320     set after [after 700 realtime-retry-now-off]
 321     set realtime_retry [list $after $pong {}]
 322 }
 323
 324 proc realtime-retry-serchan-readable {} {
 325     global realtime_retry serchan
 326     manyset $realtime_retry after pong buf
 327     set x [read $serchan]
 328     binary scan $x H* x
 329     #puts "<! picioh in await-off $x"
 330     if {![string length $x] && [eof $serchan]} { error "eof on serial port" }
 331     append buf $x
 332     while {[regexp {^((?:[89a-f].)*[0-7].)(.*)$} $buf dummy msg buf]} {
 333         if {![string compare 09 $msg]} {
 334             realtime-retry-now-off
 335             return
 336         }
 337         if {![string compare $pong $msg]} {
 338             after cancel $after
 339             set after [after 200 realtime-retry-send-ping]
 340             set realtime_retry [list $after {} {}]
 341             return
 342         }
 343     }
 344     set realtime_retry [list $after $pong $buf]
 345 }
 346
 347 proc realtime-retry-now-off {} {
 348     realtime-retry-reset
 349     realtime-retry-check
 350 }
 351
 352 #---------- connection and commands ----------
 353
 354 proc client-inputline {conn l} {
 355     global queueing
 356     upvar #0 c/$conn c
 357     puts "$conn> $l"
 358     client-disable-readable $conn
 359     if {![llength $c(q)]} { lappend queueing $conn }
 360     lappend c(q) $l
 361     after idle process-queues
 362 }
 363
 364 proc process-queues {} {
 365     global queueing currentcmd
 366     while {![info exists currentcmd] && [llength $queueing]} {
 367         set conn [lindex $queueing 0]
 368         set queueing [lrange $queueing 1 end]
 369
 370         upvar #0 c/$conn c
 371         if {![llength $c(q)]} continue
 372
 373         set l [lindex $c(q) 0]
 374         set c(q) [lrange $c(q) 1 end]
 375         if {[llength $c(q)]} {
 376             lappend queueing $conn
 377         } else {
 378             client-enable-readable $conn
 379         }
 380
 381         trapping process-command $conn $l
 382     }
 383 }
 384
 385 proc process-command {conn l} {
 386     global currentcmd currentconn realtime executing
 387     global errorInfo errorCode
 388     upvar #0 c/$conn c
 389     set cmd ?
 390     set r [catch {
 391         if {[regexp {^#} $l]} return; # comments ?!  ok then ...
 392         set l [string trim $l]
 393         if {![string length $l]} return
 394         if {![regexp {^((!?)[-+a-z0-9]+)(?:\s.*)?$} $l dummy cmd priv]} {
 395             error "improper command name" {} {TRAIN CMDNAK BadCmd}
 396         }
 397         if {[regexp {[^ \t!-~]} $l]} {
 398             error "improper character" {} {TRAIN CMDNAK BadCmd}
 399         }
 400         if {[string length $priv] && !$c(super)} {
 401             error "" {} {TRAIN CMDNAK PermissionDenied}
 402         }
 403
 404         if {![catch { info args global/$cmd }]} {
 405             set currentcmd $cmd
 406             set currentconn $conn
 407             set executing 2
 408             xmit-relevantly "executing $cmd"
 409             eval [list global/$cmd $conn] [lrange [split $l] 1 end]
 410         } elseif {![catch { info args local/$cmd }]} {
 411             xmit-only $conn "+executing $cmd"
 412             eval [list local/$cmd $conn] [lrange [split $l] 1 end]
 413         } elseif {![info exists realtime]} {
 414             error "" {} {TRAIN CMDNAK realtime-not-running}
 415         } else {
 416             set currentcmd $cmd
 417             set currentconn $conn
 418             if {[catch {
 419                 puts ">> $l"
 420                 puts $realtime $l
 421             } emsg]} {
 422                 if {[string match {POSIX EPIPE *} $errorCode]} {
 423                     realtime-failed EPIPE ""
 424                 } elseif {[string match {POSIX *} $errorCode]} {
 425                     realtime-failed [lindex $errorCode 1] \
 426                             "write failed: [lindex $errorCode 2]"
 427                 } else {
 428                     realtime-failed ?write-[lindex $errorCode 0] \
 429                             "puts failed ($errorCode): $emsg"
 430                 }
 431             }
 432             return
 433         }
 434     } emsg]
 435     if {$r==2} return
 436     if {$r==0} {
 437         set m "ack $cmd ok"
 438         if {$executing} {
 439             xmit-relevantly $m
 440             set executing 0
 441             unset currentconn
 442             unset currentcmd
 443         } else {
 444             xmit-only $conn +$m
 445         }
 446         return
 447     }
 448     switch -glob $errorCode {
 449         {TRAIN REPORTED*} {
 450         }
 451         {TRAIN CMDNAK*} {
 452             set el [concat [list +nack] [lrange $errorCode 2 end]]
 453             if {[string length $emsg]} { append el ": " $emsg }
 454             xmit-only $conn "$el"
 455         }
 456         {TRAIN CMDERR*} {
 457             set el [concat [list +ack $cmd] [lrange $errorCode 2 end]]
 458             xmit-only $conn "$el : $emsg"
 459             set executing 0
 460             catch { unset currentconn }
 461             catch { unset currentcmd }
 462         }
 463         * {
 464             set ei $errorInfo; set ec $errorCode
 465             kill-conn-ierr $conn
 466             error $emsg $ei $ec
 467         }
 468     }
 469 }
 470
 471 proc client-eof {conn} {
 472     puts "$conn>\$"
 473     kill-conn $conn ""
 474 }
 475
 476 proc client-enable-readable {conn} {
 477     fileevent $conn readable [list trapping readable client $conn]
 478 }
 479 proc client-disable-readable {conn} {
 480     fileevent $conn readable {}
 481 }
 482
 483 #---------- general IO ----------
 484
 485 proc xmit-puts {conn msg} {
 486     global conns errorInfo
 487     if {![info exists conns($conn)]} return
 488     if {[catch { puts -nonewline $conn $msg } emsg]} {
 489         kill-conn $conn "=failed client-io : $emsg"
 490         error $emsg $errorInfo {TRAIN REPORTED}
 491     }
 492 }
 493
 494 proc xmit-only-always {conn msg} {
 495     puts "<$conn $msg"
 496     xmit-puts $conn "$msg\n"
 497 }
 498 proc xmit-only-noreport {conn msg} {
 499     append msg "\n"
 500     if {[msel/$conn $msg]} { xmit-puts $conn $msg }
 501 }
 502 proc xmit-only {conn msg} {
 503     xmit-only-noreport $conn $msg
 504 }
 505
 506 #---------- error handling ----------
 507
 508 proc kill-conn {conn msg} {
 509     global conns queueing currentconn
 510     upvar #0 c/$conn c
 511     catch { unset conns($conn) } ;# do this first to stop any recursion
 512     if {[info exists currentconn]} {
 513         if {![string compare $currentconn $conn]} { set currentconn {} }
 514     }
 515     puts "<$conn\$ closing : $msg"
 516     if {[string length $msg]} { catch { xmit-only-always $conn "$msg" } }
 517     catch { close $conn }
 518     if {[set ix [lsearch -exact $queueing $conn]] >= 0} {
 519         set queueing [lreplace $queueing $ix $ix]
 520     }
 521     catch { unset c }
 522     catch { rename msel/$conn {} }
 523     catch { rename mreplay/$conn {} }
 524     set qn {}
 525     set cmdqueue $qn
 526 }
 527
 528 proc report-unexpected {headmsg emsg} {
 529     if {[catch {
 530         global errorInfo errorCode
 531         puts stderr \
 532 "========== $headmsg ==========\n
 533 $errorCode\n
 534 $errorInfo\n
 535 $emsg\n
 536 ========================================\n"
 537     } e]} { exit 16 }
 538 }
 539
 540 proc bgerror {emsg} {
 541     global errorInfo errorCode
 542     catch { report-unexpected {UNEXPECTED UNTRAPPED ERROR} $emsg }
 543     exit 12
 544 }
 545
 546 proc kill-conn-ierr {conn} {
 547     kill-conn $conn "=failed : Internal error"
 548 }
 549
 550 proc trapping {proc conn args} {
 551     global errorInfo errorCode
 552     if {![catch { uplevel #0 [list $proc $conn] $args } r]} { return $r }
 553     switch -glob $errorCode {
 554         {TRAIN EXPECTED*} { kill-conn $conn "=failed : $r" }
 555         {TRAIN REPORTED*} { kill-conn $conn "" }
 556         * {
 557             report-unexpected {UNEXPECTED ERROR} $r
 558             kill-conn-ierr $conn
 559         }
 560     }
 561 }
 562
 563 #---------- realtime subprocess ----------
 564
 565 proc realtime-failed {k m} {
 566     global realtime currentcmd currentconn executing
 567     global errorInfo errorCode replay
 568     # if $m is "", use wait status
 569     if {![string length $m]} {
 570         set r [catch {
 571             fconfigure $realtime -blocking 1
 572             close $realtime
 573         } emsg]
 574         if {!$r} {
 575             set m "unexpectedly closed pipe ?!"
 576             set k unexpected
 577         } elseif {[string match {CHILDSTATUS*} $errorCode]} {
 578             set m "exited with status [lindex $errorCode 2]"
 579             set k "exit[lindex $errorCode 2]"
 580         } elseif {[string match {CHILDKILLED*} $errorCode]} {
 581             set m "killed by signal [lindex $errorCode 3]"
 582             set k [lindex $errorCode 2]
 583         } else {
 584             set m "failed confusingly ($errorCode): $emsg"
 585             set k ?wait-[lindex $errorCode 0]
 586         }
 587     } else {
 588         catch { close $realtime }
 589     }
 590     puts "<<\$ $k : $m"
 591     catch { unset realtime }
 592     if {[catch {
 593         set sef [open +realtime.stderr r]
 594         while {[gets $sef l] >= 0} {
 595             xmit-relevantly-savereplay 40 \
 596                     "warning realtime-failed stderr" ": $l"
 597         }
 598         close $sef
 599         unset sef
 600     } emsg]} {
 601         if {![string match {POSIX ENOENT *} $errorCode]} {
 602             xmit-relevantly-savereplay 40 \
 603                     "warning realtime-failed stderr" "unreadable : $emsg"
 604         }
 605         catch { close $sef }
 606     }
 607     xmit-relevantly-savereplay 40 \
 608             "warning realtime-failed" "reason $k : $m"
 609     catch { save-dump }
 610     if {$executing==2} {
 611         # internal commands need to deal with it themselves
 612     } elseif {$executing} {
 613         xmit-relevantly "ack $currentcmd SystemFailed realtime : $m"
 614         set executing 0
 615     } elseif {[info exists currentcmd]} {
 616         xmit-relevantly "nak SystemFailed realtime : $m"
 617         unset currentcmd
 618         unset currentconn
 619     }
 620     realtime-notrunning
 621     realtime-retry-realtime-failed
 622 }
 623
 624 proc realtime-notrunning {} {
 625     xmit-relevantly-savereplay 10 stastate Crashed
 626 }
 627
 628 proc realtime-start {xopts} {
 629     global realtime records realtime_xopts dev_railway libdir
 630     if {[info exists realtime]} { error "realtime already running" }
 631     realtime-retry-reset
 632     set cl [concat \
 633             [list 2> +realtime.stderr $libdir/realtime -v2 -s$dev_railway] \
 634             $realtime_xopts $xopts]
 635     foreach f $records { lappend cl $libdir/$f }
 636     puts "<> $cl"
 637     savereplay-clear-re "40 warning realtime-failed"
 638     if {[catch {
 639         set realtime [open |$cl r+]
 640         fconfigure $realtime -translation binary -buffering line -blocking 0
 641         fileevent $realtime readable [list readable realtime $realtime]
 642     } emsg]} {
 643         realtime-failed start $emsg
 644         error "realtime failed : $emsg" "" {TRAIN REPORTED}
 645     }
 646 }
 647
 648 proc realtime-eof {dummy} { realtime-failed EOF "" }
 649
 650 proc detect0timeout {seg} {
 651     global replay
 652     upvar #0 detect0($seg) d0
 653     unset d0
 654     set key "detect $seg"
 655     set pk "70 $key"
 656     set replay($pk) 0
 657     xmit-relevantly "$key 0"
 658 }
 659
 660 proc clear-replay-detects {} {
 661     global replay
 662     foreach k [array names replay] {
 663         if {[regexp {^.. detect } $k]} { unset replay($k) }
 664     }
 665 }
 666
 667 proc realtime-inputline {dummy l} {
 668     global detectlag replay testmode
 669     global executing currentcmd currentconn
 670
 671     if {$testmode && [regexp {^%(.*)} $l dummy rhs]} {
 672         set r [catch { uplevel #0 $rhs } emsg]
 673         if {$r} { puts "** $emsg\n" } else { puts "=> $emsg\n" }
 674         return
 675     }
 676
 677     lputs "<< $l"
 678     set tlog 0
 679
 680     if {[regexp {^(detect (\w+)) ([01])$} $l dummy key seg value]} {
 681         upvar #0 detect0($seg) d0
 682         catch { after cancel $d0 }
 683         if {$value} {
 684             if {[info exists d0]} { unset d0; return }
 685         } else {
 686             set d0 [after $detectlag detect0timeout $seg]
 687             return
 688         }
 689         set pri 70
 690     } elseif {[regexp {^(stastate) (.*)$} $l dummy key value]} {
 691         switch -exact -- $value {
 692             Settling {
 693                 clear-replay-detects
 694                 savereplay-clear-re {^60 train \S+ speed }
 695             }
 696             Resolving {
 697                 savereplay-clear-re {^50 resolution }
 698                 savereplay-clear-re {^60 train \S+ (?:at|has) }
 699                 savereplay-clear-re {^60 movpos }
 700             }
 701         }
 702         set pri 10
 703         set tlog 1
 704     } elseif {[regexp {^(resolution) (.*)$} $l dummy key addvalue]} {
 705         set pri 50
 706     } elseif {[regexp {^(picio out) (on|off)$} $l dummy key value]} {
 707         set pri 55
 708     } elseif {[regexp -expanded {
 709         ^( movpos \s \S+ \s (?: feat \s \S+ | position) |
 710            train  \s \S+ \s (?: has | at | speed \s commanding ) |
 711            picio  \s out \s polarity
 712         ) \s (.*) $
 713               } $l dummy key value]} {
 714         set pri 60
 715     }
 716     if {[info exists key]} {
 717         set pk "$pri $key"
 718         upvar #0 replay($pk) rep
 719         if {[info exists value]} {
 720             set rep $value
 721         } else {
 722             append rep $addvalue "\n"
 723         }
 724     }
 725
 726     switch -regexp -- $l {
 727         {^executing\s|^nak\s} {
 728             set executing 1
 729         }
 730     }
 731
 732     xmit-relevantly $l $tlog
 733
 734     switch -regexp -- $l {
 735         {^ack\s|^nak\s} {
 736             set executing 0
 737             unset currentcmd
 738             unset currentconn
 739             after idle process-queues
 740         }
 741     }
 742 }
 743
 744 #---------- new connections ----------
 745
 746 proc find-permission {ipaddr} {
 747     global permissions
 748     set ipaddr [ipaddr2hex $ipaddr]
 749     foreach {keyword paddr pmask} $permissions {
 750         if {[expr {($ipaddr & $pmask) == $paddr}]} { return $keyword }
 751     }
 752     return deny
 753 }
 754
 755 proc connected {conn} {
 756     global conns
 757     upvar #0 c/$conn c
 758     fconfig-trainproto $conn
 759     set c(q) {}
 760     set conns($conn) 1
 761     set perm [find-permission $c(ipaddr)]
 762     switch -exact $perm {
 763         deny { kill-conn $conn =denied; return }
 764         allow { set c(super) 0 }
 765         super { set c(super) 1 }
 766         default { error "$perm ?" }
 767     }
 768     compile-glob-patterns {?info ?warning} msel/$conn
 769
 770     xmit-only-always $conn =connected
 771     xmit-only-always $conn "=permission [lindex {normal super} $c(super)]"
 772     client-enable-readable $conn
 773 }
 774
 775 proc newconn {conn ipaddr port} {
 776     upvar #0 c/$conn c
 777     catch { unset c }
 778     puts "$conn new-client $conn $ipaddr,$port"
 779     set c(ipaddr) $ipaddr
 780     trapping connected $conn
 781 }
 782
 783 proc try-bind {addr} {
 784     global master errorInfo errorCode port
 785     if {![catch {
 786         set master [socket -server newconn -myaddr $addr $port]
 787     } emsg]} { return 1 }
 788     if {[string match {POSIX EADDRNOTAVAIL *} $errorCode]} { return 0 }
 789     error $emsg $errorInfo $errorCode
 790 }
 791
 792 proc ipaddr2hex {addr} {
 793     if {![regexp {^\d+\.\d+\.\d+\.\d+$} $addr]} {
 794         error "invalid ip address $addr"
 795     }
 796     set val 0x
 797     foreach octet [split $addr .] { append val [format %02x $octet] }
 798     if {[string length $val] != 10} {
 799         error "invalid numbers in ip address $addr (calculated $val ?!)"
 800     }
 801     return $val
 802 }
 803
 804 proc binding {addr blist} {
 805     global master permissions port
 806     if {[info exists master]} return
 807     if {![try-bind $addr]} return
 808     puts "bound to $addr,$port"
 809     set permissions {}
 810     foreach {keyword pattern} $blist {
 811         switch -exact $keyword allow - super - deny { } \
 812                 default { error "unknown binding keyword $keyword" }
 813         if {![regexp {^(.*)/(\d+)$} $pattern dummy host masklen]} {
 814             set host $pattern; set masklen 32
 815         }
 816         set ipaddr [ipaddr2hex $host]
 817         set mask [expr {$masklen==0 ? 0 : 0xffffffff << (32-$masklen)}]
 818         set mask [format %#10x $mask]
 819         if {$ipaddr & ~$mask} {
 820             error "non-zero bits outside mask in $pattern ($ipaddr/$mask)"
 821         }
 822         lappend permissions $keyword $ipaddr $mask
 823     }
 824 }
 825
 826 proc startup {} {
 827     global queueing executing testmode realtime port urandom serchan
 828     global dev_railway libdir lputs
 829     catch { close $master }; catch { unset master }
 830
 831     setting testmode 0 {[01]}
 832     setting lputs 0 {[01]}
 833     setting dev_railway {} {/.*}
 834     parse-argv {}
 835
 836     uplevel #0 source $libdir/multiplex-config
 837     set queueing {}
 838     set executing 0
 839
 840     set urandom [open /dev/urandom r]
 841     fconfigure $urandom -buffering none -translation binary
 842
 843     set serchan [open $dev_railway {RDWR NOCTTY NONBLOCK}]
 844     fconfigure $serchan -translation binary -buffering none -blocking 0
 845
 846     realtime-notrunning
 847
 848     if {!$testmode} {
 849         start_commandloop
 850         after idle realtime-retry-check
 851     } else {
 852         fconfig-trainproto stdin
 853         fconfig-trainproto stdout
 854         fileevent stdin readable [list readable realtime stdin]
 855         set realtime stdout
 856     }
 857 }
 858
 859 startup
 860 vwait end