tcl: Phase 7 — try/trap, exec pipelines, string audit, regexp, TclOO [WIP]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 53s

7a try/trap: tcl-cmd-try extended with `trap pattern varlist body` clause
   matching errorcode prefix. Handler varlist supports {result optsdict}.
   Added tcl-try-trap-matches?, tcl-try-build-opts helpers.

7b exec pipelines: new exec-pipeline SX primitive parses `|`, `< file`,
   `> file`, `>> file`, `2> file`, `2>@1` and builds a process pipeline
   via Unix.pipe + create_process. tcl-cmd-exec dispatches to it on
   metachar presence.

7c string audit: added string equal (-nocase, -length), totitle, reverse,
   replace; added string is true/false/xdigit/ascii classes.

7d TclOO: minimal `oo::class create NAME body` with method/constructor/
   destructor/superclass; instances via `Cls new ?args?`; method dispatch
   via per-object Tcl command; single inheritance via :super chain.
   Stored in interp :classes / :oo-objects / :oo-counter.

7e regexp audit: existing Re.Pcre wrapper handles ^/$ anchors, \\b
   boundaries, -nocase, captures, regsub -all. Added regression tests.

+22 idiom tests (5 try, 5 exec pipeline, 7 string, 6 regexp, 5 TclOO).

[WIP — full suite verification pending]

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
2026-05-08 22:45:16 +00:00
parent 21028c4fb0
commit 14986d787d
3 changed files with 681 additions and 6 deletions

View File

@@ -3599,6 +3599,148 @@ let () =
else "")))
else String trimmed);
(* exec-pipeline: takes a list of words like Tcl `exec` would receive.
Recognizes `|` as a stage separator and `> file`, `>> file`, `< file`,
`2>@1` (stderr→stdout), `2> file`. Returns trimmed stdout of the last
stage; raises Eval_error if the last stage exits non-zero. *)
register "exec-pipeline" (fun args ->
let items = match args with
| [List xs] | [ListRef { contents = xs }] -> xs
| _ -> raise (Eval_error "exec-pipeline: (word-list)")
in
let words = List.map (function
| String s -> s
| v -> Sx_types.inspect v
) items in
if words = [] then raise (Eval_error "exec: empty command");
let split_stages ws =
let rec loop acc cur = function
| [] -> List.rev (List.rev cur :: acc)
| "|" :: rest -> loop (List.rev cur :: acc) [] rest
| w :: rest -> loop acc (w :: cur) rest
in
loop [] [] ws
in
let extract_redirs ws =
let in_path = ref None in
let out_path = ref None in
let out_append = ref false in
let err_path = ref None in
let merge_err = ref false in
let cleaned = ref [] in
let rec loop = function
| [] -> ()
| "<" :: p :: rest -> in_path := Some p; loop rest
| ">" :: p :: rest -> out_path := Some p; out_append := false; loop rest
| ">>" :: p :: rest -> out_path := Some p; out_append := true; loop rest
| "2>@1" :: rest -> merge_err := true; loop rest
| "2>" :: p :: rest -> err_path := Some p; loop rest
| w :: rest -> cleaned := w :: !cleaned; loop rest
in
loop ws;
(List.rev !cleaned, !in_path, !out_path, !out_append, !err_path, !merge_err)
in
let stages = List.map extract_redirs (split_stages words) in
if stages = [] then raise (Eval_error "exec: no stages");
let n = List.length stages in
let pipes = Array.init (max 0 (n - 1)) (fun _ -> Unix.pipe ()) in
let (final_r, final_w) = Unix.pipe () in
let (errstash_r, errstash_w) = Unix.pipe () in
let pids = ref [] in
let close_safe fd = try Unix.close fd with _ -> () in
let open_in_redir = function
| None -> Unix.stdin
| Some path ->
(try Unix.openfile path [Unix.O_RDONLY] 0o644
with Unix.Unix_error (e, _, _) ->
raise (Eval_error ("exec: open <" ^ path ^ ": " ^ Unix.error_message e)))
in
let open_out_redir path append =
let flags = Unix.O_WRONLY :: Unix.O_CREAT :: (if append then [Unix.O_APPEND] else [Unix.O_TRUNC]) in
try Unix.openfile path flags 0o644
with Unix.Unix_error (e, _, _) ->
raise (Eval_error ("exec: open >" ^ path ^ ": " ^ Unix.error_message e))
in
let stages_arr = Array.of_list stages in
(try
Array.iteri (fun i (cleaned, ip, op, app, ep, merge) ->
if cleaned = [] then raise (Eval_error "exec: empty stage in pipeline");
let argv = Array.of_list cleaned in
let stdin_fd =
if i = 0 then open_in_redir ip
else fst pipes.(i - 1)
in
let stdout_fd =
if i = n - 1 then
(match op with
| None -> final_w
| Some path -> open_out_redir path app)
else snd pipes.(i)
in
let stderr_fd =
if merge then stdout_fd
else (match ep with
| None -> if i = n - 1 then errstash_w else Unix.stderr
| Some path -> open_out_redir path false)
in
let pid =
try Unix.create_process argv.(0) argv stdin_fd stdout_fd stderr_fd
with Unix.Unix_error (e, _, _) ->
raise (Eval_error ("exec: " ^ argv.(0) ^ ": " ^ Unix.error_message e))
in
pids := pid :: !pids;
if i > 0 then close_safe (fst pipes.(i - 1));
if i < n - 1 then close_safe (snd pipes.(i));
if i = 0 && ip <> None then close_safe stdin_fd;
if i = n - 1 && op <> None then close_safe stdout_fd;
if not merge && ep <> None then close_safe stderr_fd
) stages_arr
with e ->
close_safe final_r; close_safe final_w;
close_safe errstash_r; close_safe errstash_w;
Array.iter (fun (a,b) -> close_safe a; close_safe b) pipes;
raise e);
close_safe final_w;
close_safe errstash_w;
let buf = Buffer.create 256 in
let errbuf = Buffer.create 64 in
let chunk = Bytes.create 4096 in
let read_all fd target =
try
let stop = ref false in
while not !stop do
let r = Unix.read fd chunk 0 (Bytes.length chunk) in
if r = 0 then stop := true
else Buffer.add_subbytes target chunk 0 r
done
with _ -> ()
in
read_all final_r buf;
read_all errstash_r errbuf;
close_safe final_r;
close_safe errstash_r;
let exit_codes = List.rev_map (fun pid ->
let (_, st) = Unix.waitpid [] pid in
match st with
| Unix.WEXITED c -> c
| _ -> 1
) !pids in
let final_code = match List.rev exit_codes with
| [] -> 0
| last :: _ -> last
in
let s = Buffer.contents buf in
let trimmed =
if String.length s > 0 && s.[String.length s - 1] = '\n'
then String.sub s 0 (String.length s - 1) else s
in
if final_code <> 0 then
raise (Eval_error ("exec: pipeline last stage exited " ^ string_of_int final_code
^ (if Buffer.length errbuf > 0
then ": " ^ Buffer.contents errbuf
else "")))
else String trimmed);
(* === 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