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
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:
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user