From d21cde336a31f8402021b5846b596cf8da702e35 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 6 May 2026 18:10:22 +0000 Subject: [PATCH] =?UTF-8?q?tcl:=20Phase=203=20OCaml=20primitives=20?= =?UTF-8?q?=E2=80=94=20file-read/write/append/exists=3F/glob=20+=20clock-s?= =?UTF-8?q?econds/milliseconds/format=20in=20sx=5Fprimitives.ml=20+=20unix?= =?UTF-8?q?=20dep;=20tcl-cmd-clock/file=20wired=20up;=20337/337=20green?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored-By: Claude Sonnet 4.6 --- hosts/ocaml/lib/dune | 2 +- hosts/ocaml/lib/sx_primitives.ml | 141 ++++++++++++++++++++++++++++++- lib/tcl/runtime.sx | 10 ++- lib/tcl/tests/coro.sx | 12 +-- 4 files changed, 153 insertions(+), 12 deletions(-) diff --git a/hosts/ocaml/lib/dune b/hosts/ocaml/lib/dune index 4dd17fc1..0a5bf1a7 100644 --- a/hosts/ocaml/lib/dune +++ b/hosts/ocaml/lib/dune @@ -1,4 +1,4 @@ (library (name sx) (wrapped false) - (libraries re re.pcre)) + (libraries re re.pcre unix)) diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 3e0768f4..4a0cd7f8 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -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])")) diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index e9d1e4f1..d8c77649 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -2865,10 +2865,12 @@ (let ((sub (first args)) (rest-args (rest args))) (cond - ((equal? sub "seconds") (assoc interp :result "0")) - ((equal? sub "milliseconds") (assoc interp :result "0")) + ((equal? sub "seconds") (assoc interp :result (str (clock-seconds)))) + ((equal? sub "milliseconds") (assoc interp :result (str (clock-milliseconds)))) ((equal? sub "format") - (assoc interp :result "Thu Jan 1 00:00:00 UTC 1970")) + (assoc interp :result (clock-format + (floor (parse-int (first rest-args))) + (if (> (len rest-args) 1) (nth rest-args (- (len rest-args) 1)) "%a %b %e %H:%M:%S %Z %Y")))) ((equal? sub "scan") (assoc interp :result "0")) (else (error (str "clock: unknown subcommand \"" sub "\"")))))))) @@ -3151,7 +3153,7 @@ (let ((sub (first args)) (rest-args (rest args))) (cond - ((equal? sub "exists") (assoc interp :result "0")) + ((equal? sub "exists") (assoc interp :result (if (file-exists? (first rest-args)) "1" "0"))) ((equal? sub "join") (assoc interp :result (join "/" rest-args))) ((equal? sub "split") (assoc diff --git a/lib/tcl/tests/coro.sx b/lib/tcl/tests/coro.sx index 541ee625..925844e7 100644 --- a/lib/tcl/tests/coro.sx +++ b/lib/tcl/tests/coro.sx @@ -95,15 +95,15 @@ (get (run "proc g {} { yield }\ncoroutine cg g\ncg") :result) "") - ; --- clock seconds stub --- + ; --- clock seconds --- (ok "clock-seconds" - (get (run "clock seconds") :result) - "0") + (> (parse-int (get (run "clock seconds") :result)) 0) + true) - ; --- clock milliseconds stub --- + ; --- clock milliseconds --- (ok "clock-milliseconds" - (get (run "clock milliseconds") :result) - "0") + (> (parse-int (get (run "clock milliseconds") :result)) 0) + true) ; --- clock format stub --- (ok "clock-format"