tcl: Phase 3 OCaml primitives — file-read/write/append/exists?/glob + clock-seconds/milliseconds/format in sx_primitives.ml + unix dep; tcl-cmd-clock/file wired up; 337/337 green
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 50s

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
2026-05-06 18:10:22 +00:00
parent f0f339709e
commit d21cde336a
4 changed files with 153 additions and 12 deletions

View File

@@ -1,4 +1,4 @@
(library
(name sx)
(wrapped false)
(libraries re re.pcre))
(libraries re re.pcre unix))

View File

@@ -1871,4 +1871,143 @@ let () =
| [rx] ->
let (_, _, flags) = regex_of_value rx in
String flags
| _ -> raise (Eval_error "regex-flags: (regex)"))
| _ -> raise (Eval_error "regex-flags: (regex)"));
(* === File I/O === *)
register "file-read" (fun args ->
match args with
| [String path] ->
(try
let ic = open_in path in
let n = in_channel_length ic in
let s = Bytes.create n in
really_input ic s 0 n;
close_in ic;
String (Bytes.to_string s)
with Sys_error msg -> raise (Eval_error ("file-read: " ^ msg)))
| _ -> raise (Eval_error "file-read: (path)"));
register "file-write" (fun args ->
match args with
| [String path; String content] ->
(try
let oc = open_out path in
output_string oc content;
close_out oc;
Nil
with Sys_error msg -> raise (Eval_error ("file-write: " ^ msg)))
| _ -> raise (Eval_error "file-write: (path content)"));
register "file-append" (fun args ->
match args with
| [String path; String content] ->
(try
let oc = open_out_gen [Open_append; Open_creat; Open_wronly; Open_text] 0o644 path in
output_string oc content;
close_out oc;
Nil
with Sys_error msg -> raise (Eval_error ("file-append: " ^ msg)))
| _ -> raise (Eval_error "file-append: (path content)"));
register "file-exists?" (fun args ->
match args with
| [String path] -> Bool (Sys.file_exists path)
| _ -> raise (Eval_error "file-exists?: (path)"));
register "file-glob" (fun args ->
let glob_match pat str =
let pn = String.length pat and sn = String.length str in
let rec go pi si =
if pi = pn then si = sn
else match pat.[pi] with
| '*' ->
let rec try_from i = i <= sn && (go (pi+1) i || try_from (i+1)) in
try_from si
| '?' -> si < sn && go (pi+1) (si+1)
| '[' ->
let pi' = ref (pi+1) in
let negate = !pi' < pn && pat.[!pi'] = '^' in
if negate then incr pi';
let matched = ref false in
while !pi' < pn && pat.[!pi'] <> ']' do
let c1 = pat.[!pi'] in
incr pi';
if !pi' + 1 < pn && pat.[!pi'] = '-' then begin
let c2 = pat.[!pi' + 1] in
pi' := !pi' + 2;
if si < sn && str.[si] >= c1 && str.[si] <= c2 then matched := true
end else if si < sn && str.[si] = c1 then matched := true
done;
if !pi' < pn then incr pi';
((!matched && not negate) || (not !matched && negate)) && go !pi' (si+1)
| c -> si < sn && str.[si] = c && go (pi+1) (si+1)
in go 0 0
in
let glob_paths pat =
let dir = Filename.dirname pat in
let base_pat = Filename.basename pat in
let dir' = if dir = "." && not (String.length pat > 1 && pat.[0] = '.') then "." else dir in
(try
let entries = Sys.readdir dir' in
Array.fold_left (fun acc entry ->
if glob_match base_pat entry then
let full = if dir' = "." then entry else Filename.concat dir' entry in
full :: acc
else acc
) [] entries
|> List.sort String.compare
with Sys_error _ -> [])
in
match args with
| [String pat] -> List (List.map (fun s -> String s) (glob_paths pat))
| _ -> raise (Eval_error "file-glob: (pattern)"));
(* === Clock === *)
register "clock-seconds" (fun args ->
match args with
| [] -> Number (Float.round (Unix.gettimeofday ()))
| _ -> raise (Eval_error "clock-seconds: no args"));
register "clock-milliseconds" (fun args ->
match args with
| [] -> Number (Float.round (Unix.gettimeofday () *. 1000.0))
| _ -> raise (Eval_error "clock-milliseconds: no args"));
register "clock-format" (fun args ->
match args with
| [Number t_f] | [Number t_f; String _] ->
let t = int_of_float t_f in
let fmt = (match args with [_; String f] -> f | _ -> "%a %b %e %H:%M:%S %Z %Y") in
let tm = Unix.gmtime (float_of_int t) in
let buf = Buffer.create 32 in
let n = String.length fmt in
let i = ref 0 in
while !i < n do
if fmt.[!i] = '%' && !i + 1 < n then begin
(match fmt.[!i + 1] with
| 'Y' -> Buffer.add_string buf (Printf.sprintf "%04d" (1900 + tm.Unix.tm_year))
| 'm' -> Buffer.add_string buf (Printf.sprintf "%02d" (tm.Unix.tm_mon + 1))
| 'd' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_mday)
| 'e' -> Buffer.add_string buf (Printf.sprintf "%2d" tm.Unix.tm_mday)
| 'H' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_hour)
| 'M' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_min)
| 'S' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_sec)
| 'j' -> Buffer.add_string buf (Printf.sprintf "%03d" (tm.Unix.tm_yday + 1))
| 'Z' -> Buffer.add_string buf "UTC"
| 'a' -> let days = [|"Sun";"Mon";"Tue";"Wed";"Thu";"Fri";"Sat"|] in
Buffer.add_string buf days.(tm.Unix.tm_wday)
| 'A' -> let days = [|"Sunday";"Monday";"Tuesday";"Wednesday";"Thursday";"Friday";"Saturday"|] in
Buffer.add_string buf days.(tm.Unix.tm_wday)
| 'b' | 'h' -> let mons = [|"Jan";"Feb";"Mar";"Apr";"May";"Jun";"Jul";"Aug";"Sep";"Oct";"Nov";"Dec"|] in
Buffer.add_string buf mons.(tm.Unix.tm_mon)
| 'B' -> let mons = [|"January";"February";"March";"April";"May";"June";"July";"August";"September";"October";"November";"December"|] in
Buffer.add_string buf mons.(tm.Unix.tm_mon)
| c -> Buffer.add_char buf '%'; Buffer.add_char buf c);
i := !i + 2
end else begin
Buffer.add_char buf fmt.[!i];
incr i
end
done;
String (Buffer.contents buf)
| _ -> raise (Eval_error "clock-format: (seconds [format])"))