Merge remote-tracking branch 'origin/loops/tcl' into architecture

hosts/ocaml/lib/sx_primitives.ml

@@ -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 ->

lib/tcl/runtime.sx

@@ -362,8 +362,13 @@
             (is-chan
               (and
                 (not (nil? maybe-chan))
-                (>= (len maybe-chan) 4)
+                (or
-                (equal? (slice maybe-chan 0 4) "file"))))
+                  (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)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))

lib/tcl/tests/idioms.sx

@@ -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