coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions 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

80
hosts/ocaml/lib/sx_primitives.ml
View File

@@ -3297,6 +3297,86 @@ let () =
Nil
| _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
(* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *)
let resolve_inet_addr host =
if host = "" || host = "0.0.0.0" then Unix.inet_addr_any
else if host = "localhost" then Unix.inet_addr_loopback
else
try Unix.inet_addr_of_string host
with _ ->
try
let entry = Unix.gethostbyname host in
if Array.length entry.Unix.h_addr_list = 0 then
raise (Eval_error ("socket: cannot resolve " ^ host))
else entry.Unix.h_addr_list.(0)
with Not_found -> raise (Eval_error ("socket: cannot resolve " ^ host))
in
let port_of v = match v with
| Integer n -> n
| Number n -> int_of_float n
| _ -> raise (Eval_error "socket: port must be a number")
in
let alloc_chan_name () =
let id = !channel_next_id in
incr channel_next_id;
Printf.sprintf "sock%d" id
in
register "socket-connect" (fun args ->
match args with
| [String host; port_v] ->
let port = port_of port_v in
let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
(try Unix.connect sock addr
with Unix.Unix_error (e, _, _) ->
(try Unix.close sock with _ -> ());
raise (Eval_error ("socket-connect: " ^ Unix.error_message e)));
let name = alloc_chan_name () in
Hashtbl.replace channel_table name (sock, "rw", ref false, ref true);
String name
| _ -> raise (Eval_error "socket-connect: (host port)"));
register "socket-server" (fun args ->
let (host, port) = match args with
| [port_v] -> ("", port_of port_v)
| [String h; port_v] -> (h, port_of port_v)
| _ -> raise (Eval_error "socket-server: (port) or (host port)")
in
let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Unix.setsockopt sock Unix.SO_REUSEADDR true;
(try Unix.bind sock addr
with Unix.Unix_error (e, _, _) ->
(try Unix.close sock with _ -> ());
raise (Eval_error ("socket-server: bind: " ^ Unix.error_message e)));
Unix.listen sock 8;
let name = alloc_chan_name () in
Hashtbl.replace channel_table name (sock, "server", ref false, ref true);
String name);
register "socket-accept" (fun args ->
match args with
| [String name] ->
let (sock, _, _, _) = chan_get name in
let (client_sock, client_addr) =
try Unix.accept sock
with Unix.Unix_error (e, _, _) ->
raise (Eval_error ("socket-accept: " ^ Unix.error_message e))
in
let (host_str, port) = match client_addr with
| Unix.ADDR_INET (addr, p) -> (Unix.string_of_inet_addr addr, p)
| Unix.ADDR_UNIX path -> (path, 0)
in
let client_name = alloc_chan_name () in
Hashtbl.replace channel_table client_name (client_sock, "rw", ref false, ref true);
let d = Hashtbl.create 3 in
Hashtbl.replace d "channel" (String client_name);
Hashtbl.replace d "host" (String host_str);
Hashtbl.replace d "port" (Integer port);
Dict d
| _ -> raise (Eval_error "socket-accept: (server-channel)"));
(* io-select-channels: (read-list write-list timeout-ms) → {:readable [...] :writable [...]}
timeout-ms < 0 → block indefinitely; 0 → poll. Returns ready channel names. *)
register "io-select-channels" (fun args ->

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