coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions 1 Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/loops/tcl' into architecture
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m4s
Details

Browse Source
This commit is contained in:
giles
2026-05-07 16:50:27 +00:00
parent b6cf20dac7 c8b232d40e
commit d27622d45e
3 changed files with 176 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

70
lib/tcl/runtime.sx
View File

@@ -362,8 +362,13 @@
(is-chan
(and
(not (nil? maybe-chan))
(>= (len maybe-chan) 4)
(equal? (slice maybe-chan 0 4) "file"))))
(or
(and
(>= (len maybe-chan) 4)
(equal? (slice maybe-chan 0 4) "file"))
(and
(>= (len maybe-chan) 4)
(equal? (slice maybe-chan 0 4) "sock"))))))
(if
is-chan
(let
@@ -3199,6 +3204,61 @@
(interp args)
(assoc (tcl-event-step interp 0) :result "")))
; ============================================================
; Socket: TCP client and server (Phase 5c)
; ============================================================
; Internal command invoked by the auto-registered fileevent on a server
; channel. Args: (server-chan callback-word ...). Accepts one client and
; calls the user callback with (client-chan peer-host peer-port).
(define
tcl-cmd-_sock-do-accept
(fn
(interp args)
(let
((server-chan (first args)) (cb-parts (rest args)))
(let
((info (socket-accept server-chan)))
(let
((client-chan (get info :channel))
(peer-host (get info :host))
(peer-port (str (get info :port))))
(let
((cmd
(join
" "
(append
cb-parts
(list client-chan peer-host peer-port)))))
(assoc (tcl-eval-string interp cmd) :result "")))))))
; socket host port — TCP client; returns "sockN"
; socket -server cb port — TCP server; auto-fires cb on each accept
(define
tcl-cmd-socket
(fn
(interp args)
(cond
((= 0 (len args)) (error "socket: wrong # args"))
((equal? (first args) "-server")
(if
(< (len args) 3)
(error "socket: usage: socket -server cb port")
(let
((cb (nth args 1)) (port (parse-int (nth args 2))))
(let
((server-chan (socket-server port)))
(let
((handler (str "_sock-do-accept " server-chan " " cb)))
(assoc
(tcl-fileevent-set interp server-chan "readable" handler)
:result server-chan))))))
((= 2 (len args))
(let
((host (first args)) (port (parse-int (nth args 1))))
(assoc interp :result (socket-connect host port))))
(else (error "socket: wrong # args")))))
(define
tcl-cmd-array
@@ -3689,6 +3749,10 @@
((i (tcl-register i "vwait" tcl-cmd-vwait)))
(let
((i (tcl-register i "update" tcl-cmd-update)))
(let
((i (tcl-register i "socket" tcl-cmd-socket)))
(let
((i (tcl-register i "_sock-do-accept" tcl-cmd-_sock-do-accept)))
(let
((i (tcl-register i "file" tcl-cmd-file)))
(let
@@ -3700,4 +3764,4 @@
(tcl-register
i
"array"
tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))

29
lib/tcl/tests/idioms.sx
View File

@@ -274,6 +274,35 @@
:result)
"1")
; 38-41. Phase 5c sockets: TCP client + server
(ok "socket-server-fires-callback"
(get
(run
"proc h {sock host port} { global got; set got hit; close $sock }\nset srv [socket -server h 18901]\nset cli [socket localhost 18901]\nvwait got\nclose $srv\nclose $cli\nset got")
:result)
"hit")
(ok "socket-client-server-roundtrip"
(get
(run
"proc h {sock host port} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server h 18902]\nset cli [socket localhost 18902]\nputs $cli ping\nflush $cli\nvwait received\nclose $srv\nclose $cli\nset received")
:result)
"ping")
(ok "socket-server-peer-host"
(get
(run
"proc h {sock host port} { global peer; set peer $host; close $sock }\nset srv [socket -server h 18903]\nset cli [socket 127.0.0.1 18903]\nvwait peer\nclose $srv\nclose $cli\nset peer")
:result)
"127.0.0.1")
(ok "socket-multiple-connections"
(get
(run
"proc h {sock host port} { global count; incr count; close $sock }\nset count 0\nset srv [socket -server h 18904]\nset c1 [socket localhost 18904]\nset c2 [socket localhost 18904]\nset c3 [socket localhost 18904]\nwhile {$count < 3} { update; after 5 }\nclose $srv\nclose $c1\nclose $c2\nclose $c3\nset count")
:result)
"3")
(dict
"passed"
tcl-idiom-pass