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