From: ian <ian>
Date: Fri, 23 May 2008 21:50:39 +0000 (+0000)
Subject: multiplex wip
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ijackson/git?a=commitdiff_plain;h=2f9b92ac558fff2fb062ced47a8a1ce375dd5c39;p=trains.git

multiplex wip
---

diff --git a/hostside/multiplex b/hostside/multiplex
index 5c75b85..fb45a14 100755
--- a/hostside/multiplex
+++ b/hostside/multiplex
@@ -1,4 +1,120 @@
-#!/usr/bin/tclsh8.4
+x#!/usr/bin/tclsh8.4
+
+#---------- i/o to realtime ----------
+
+proc cmdqueue-check {args} { }
+
+proc compile-glob-patterns {pats procname} {
+    foreach pat $pats {
+	if {[catch { string match $pat "" } emsg]} {
+	    
+
+proc cmd/select {args} {
+    upvar #0 c/$conn c
+    check-glob-patterns $args
+    set c(selected) $args
+}
+
+#---------- connection and commands ----------
+
+proc client-inputline {conn l} {
+    global errorInfo errorCode
+    global cmdqueue
+    upvar #0 c/$conn c
+    set cmd ?
+    set r [catch {
+	if {[regexp {^#}] $l} return; # comments ?!  ok then ...
+	set l [string trim $l]
+	if {![string length $l]} return
+	if {![regexp {^((!?)[-a-z0-9]+)(?:\s.*)?$} $l dummy cmd priv]} {
+	    error "improper command name" {} {TRAIN CMDNAK invalid-syntax}
+	}
+	if {[regexp {[^ \t!-~]} $l]} {
+	    error "improper character" {} {TRAIN CMDNAK invalid-syntax}
+	}
+	if {[string length $priv && !$c(super)]} {
+	    error "" {} {TRAIN CMDNAK permission-denied}
+	}
+	if {![catch { info args cmd/$cmd }]} {
+	    xmit $conn "+executing $cmd\n"
+	    eval [list cmd/$cmd $conn] [split $l]
+	} else {
+	    lappend cmdqueue $conn $l
+	    after idle cmdqueue-check
+	}
+    } emsg]
+    if {$r==0 || $r==2} return
+    switch -glob $errorCode {
+	{TRAIN CMDNAK*} {
+	    set el [concat [list +nack] [lrange $errorCode 2 end]]
+	    if {[string length $emsg]} { append el ": " $emsg }
+	    xmit $conn "$el\n"
+	}
+	{TRAIN CMDERR*} {
+	    set el [concat [list +ack $cmd] [lrange $errorCode 2 end]]
+	    xmit $conn "$el : $emsg\n"
+	}
+	* {
+	    error $emsg $errorInfo $errorCode
+	}
+    }
+}
+
+proc client-eof {conn} { kill-conn $conn "" }
+
+#---------- general IO ----------
+
+proc readable {$conn whatfor} {
+    while {[gets $conn l]>=0} { $whatfor-inputline $conn $l }
+    if {[eof $conn]} { $whatfor-eof $conn }
+}
+
+proc xmit {conn msg} { puts -nonewline $conn $msg }
+
+#---------- error handling ----------
+
+proc kill-conn {conn msg} {
+    upvar #0 c/$conn c
+    global cmdqueue
+    if {[string length $msg]} { catch { client-out $conn $msg } }
+    catch { close $conn }
+    catch { unset c }
+    set qn {}
+    foreach tconn tl $cmdqueue {
+	if {[string compare $tconn $tl]} { lappend qn $tconn $tl }
+    }
+    set cmdqueue $qn
+    fixme delete compiled glob patterns proc
+}
+
+proc report-unexpected {headmsg emsg} {
+    puts stderr \
+"========== $headmsg ==========\n\
+$r\n\
+$errorInfo\n\
+$errorCode\n"
+}
+
+proc bgerror {emsg} {
+    global errorInfo errorCode
+    catch { report-unexpected {UNEXPECTED UNTRAPPED ERROR} $emsg }
+    exit 127
+}
+
+proc trapping {proc conn args} {
+    global errorInfo errorCode
+    if {![catch { eval #0 [list $proc $conn] $args } r]} { return $r }
+    switch -glob $errorCode {
+	{TRAIN EXPECTED*} { kill-conn $conn "=failed : $r\n" }
+	{TRAIN SILENT*} { kill-conn $conn }
+	* {
+	    report-unexpected {UNEXPECTED ERROR} $r
+            kill-conn $conn "=failed : Internal error\n"
+	}
+    }
+}	
+
+#---------- new connections ----------
 
 proc find-permission {ipaddr} {
     global permissions
@@ -19,15 +135,14 @@ proc connected {conn} {
 	super { set c(super) 1 }
 	default { error "$perm ?" }
     }
-    xmit $conn =connected
-    xmit $conn =permission [lindex {normal super} $c(super)]
-    fileevent $conn readable [list trapping readable $conn]
+    set c(selected) {}   fixme make compiled globs
+    fixme list of things per conn
+    
+    xmit-always $conn =connected
+    xmit-always $conn =permission [lindex {normal super} $c(super)]
+    fileevent $conn readable [list trapping readable $conn client]
 }
 
-proc trapping {proc conn args} {
-    if {[catch {
-	eval $proc 
-
 proc newconn {conn ipaddr port} {
     upvar #0 c/$conn c
     catch { unset c }