From 63ad4563cba7152e2b7d01da8c1f43c32cce24c5 Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 7 May 2026 18:28:49 +0000 Subject: [PATCH] =?UTF-8?q?tcl:=20Phase=205d/5e/5f=20=E2=80=94=20file=20op?= =?UTF-8?q?s,=20clock=20locale+scan,=20socket=20-async?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Phase 5d (file metadata + ops): - 11 SX primitives: file-size/mtime/stat/isfile?/isdir?/readable?/writable?/ delete/mkdir/copy/rename — wrap Unix.stat/access/unlink/mkdir/rename - Tcl `file` subcommands real (were stubs): isfile, isdir, readable, writable, size, mtime, atime, type, mkdir, copy, rename, delete - file delete/copy/rename strip leading-`-` flags - +10 idiom tests Phase 5e (clock options + scan): - clock-format extended to (t fmt tz), tz ∈ utc|local - Added specifiers: %y, %I, %p, %w, %% - New clock-scan SX primitive — format-driven parser + manual timegm - Tcl clock format/scan accept -format, -timezone, -gmt 0|1 - +5 idiom tests Phase 5f (socket -async): - socket-connect-async SX primitive: Unix.set_nonblock + connect, catches EINPROGRESS; returns channel immediately - channel-async-error: Unix.getsockopt_error - Tcl `socket -async host port`; `fconfigure $sock -error` - Connection completes on writable; canonical fileevent pattern works - +3 idiom tests Bug fix: tcl-call-proc was discarding :fileevents/:timers/:procs updates made inside Tcl procs (only :commands forwarded). Now forwards full result-interp as base, restoring caller's frame/stack/result/output/code. This was masked until socket-async made fileevent-from-inside-proc the natural pattern. test.sh inner timeout bumped 1200s→2400s (post-merge JIT remains slow). 376/376 green. Co-Authored-By: Claude Sonnet 4.6 --- hosts/ocaml/lib/sx_primitives.ml | 250 ++++++++++++++++++++++++++++++- lib/tcl/runtime.sx | 160 +++++++++++++++----- lib/tcl/test.sh | 2 +- lib/tcl/tests/idioms.sx | 112 ++++++++++++++ 4 files changed, 481 insertions(+), 43 deletions(-) diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 96b4fed7..96497036 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -3091,6 +3091,108 @@ let () = | [String pat] -> List (List.map (fun s -> String s) (glob_paths pat)) | _ -> raise (Eval_error "file-glob: (pattern)")); + (* === File metadata + ops (Phase 5d) === *) + let stat_or = function + | String path -> (try Some (Unix.stat path) with _ -> None) + | _ -> raise (Eval_error "file: path must be a string") + in + register "file-size" (fun args -> + match args with + | [v] -> (match stat_or v with Some s -> Integer s.Unix.st_size | None -> Integer 0) + | _ -> raise (Eval_error "file-size: (path)")); + register "file-mtime" (fun args -> + match args with + | [v] -> (match stat_or v with Some s -> Integer (int_of_float s.Unix.st_mtime) | None -> Integer 0) + | _ -> raise (Eval_error "file-mtime: (path)")); + register "file-isfile?" (fun args -> + match args with + | [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_REG) | None -> Bool false) + | _ -> raise (Eval_error "file-isfile?: (path)")); + register "file-isdir?" (fun args -> + match args with + | [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_DIR) | None -> Bool false) + | _ -> raise (Eval_error "file-isdir?: (path)")); + register "file-readable?" (fun args -> + match args with + | [String path] -> + Bool (try Unix.access path [Unix.R_OK]; true with _ -> false) + | _ -> raise (Eval_error "file-readable?: (path)")); + register "file-writable?" (fun args -> + match args with + | [String path] -> + Bool (try Unix.access path [Unix.W_OK]; true with _ -> false) + | _ -> raise (Eval_error "file-writable?: (path)")); + register "file-stat" (fun args -> + match args with + | [v] -> + (match stat_or v with + | None -> Nil + | Some s -> + let d = Hashtbl.create 6 in + Hashtbl.replace d "size" (Integer s.Unix.st_size); + Hashtbl.replace d "mtime" (Integer (int_of_float s.Unix.st_mtime)); + Hashtbl.replace d "atime" (Integer (int_of_float s.Unix.st_atime)); + Hashtbl.replace d "ctime" (Integer (int_of_float s.Unix.st_ctime)); + Hashtbl.replace d "mode" (Integer s.Unix.st_perm); + Hashtbl.replace d "type" (String (match s.Unix.st_kind with + | Unix.S_REG -> "file" | Unix.S_DIR -> "directory" + | Unix.S_LNK -> "link" | Unix.S_CHR -> "characterSpecial" + | Unix.S_BLK -> "blockSpecial" | Unix.S_FIFO -> "fifo" + | Unix.S_SOCK -> "socket")); + Dict d) + | _ -> raise (Eval_error "file-stat: (path)")); + register "file-delete" (fun args -> + match args with + | [String path] -> + (try + if Sys.is_directory path then Unix.rmdir path + else Unix.unlink path + with + | Unix.Unix_error (Unix.ENOENT, _, _) -> () (* tolerate missing *) + | Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-delete: " ^ Unix.error_message e))); + Nil + | _ -> raise (Eval_error "file-delete: (path)")); + register "file-mkdir" (fun args -> + match args with + | [String path] -> + let rec mk p = + if p = "" || p = "." || p = "/" then () + else if Sys.file_exists p then () + else begin + mk (Filename.dirname p); + (try Unix.mkdir p 0o755 + with Unix.Unix_error (Unix.EEXIST, _, _) -> ()) + end + in + (try mk path + with Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-mkdir: " ^ Unix.error_message e))); + Nil + | _ -> raise (Eval_error "file-mkdir: (path)")); + register "file-copy" (fun args -> + match args with + | [String src; String dst] -> + (try + let ic = open_in_bin src in + let oc = open_out_bin dst in + let buf = Bytes.create 8192 in + let rec loop () = + let n = input ic buf 0 (Bytes.length buf) in + if n > 0 then (output oc buf 0 n; loop ()) + in + loop (); + close_in ic; + close_out oc; + Nil + with + | Sys_error msg -> raise (Eval_error ("file-copy: " ^ msg))) + | _ -> raise (Eval_error "file-copy: (src dst)")); + register "file-rename" (fun args -> + match args with + | [String src; String dst] -> + (try Sys.rename src dst with Sys_error msg -> raise (Eval_error ("file-rename: " ^ msg))); + Nil + | _ -> raise (Eval_error "file-rename: (src dst)")); + (* === Channels (random-access + blocking control) === *) let channel_table : (string, Unix.file_descr * string * bool ref * bool ref) Hashtbl.t = Hashtbl.create 16 in let channel_next_id = ref 0 in @@ -3304,6 +3406,43 @@ let () = String name | _ -> raise (Eval_error "socket-connect: (host port)")); + (* Non-blocking connect: returns channel immediately. Connection completes + when the channel becomes writable; query channel-async-error? after to + confirm success or get the error. *) + register "socket-connect-async" (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 + Unix.set_nonblock sock; + (try Unix.connect sock addr + with + | Unix.Unix_error (Unix.EINPROGRESS, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> () + | Unix.Unix_error (e, _, _) -> + (try Unix.close sock with _ -> ()); + raise (Eval_error ("socket-connect-async: " ^ Unix.error_message e))); + let name = alloc_chan_name () in + Hashtbl.replace channel_table name (sock, "rw", ref false, ref false); + String name + | _ -> raise (Eval_error "socket-connect-async: (host port)")); + + (* After a non-blocking connect completes (channel writable), check whether + the connect succeeded. Returns "" on success, error message on failure. *) + register "channel-async-error" (fun args -> + match args with + | [String name] -> + let (fd, _, _, _) = chan_get name in + (try + let err = Unix.getsockopt_error fd in + match err with + | None -> String "" + | Some e -> String (Unix.error_message e) + with + | Unix.Unix_error (e, _, _) -> String (Unix.error_message e)) + | _ -> raise (Eval_error "channel-async-error: (channel)")); + register "socket-server" (fun args -> let (host, port) = match args with | [port_v] -> ("", port_of port_v) @@ -3399,11 +3538,8 @@ let () = | [] -> Integer (int_of_float (Unix.gettimeofday () *. 1000.0)) | _ -> raise (Eval_error "clock-milliseconds: no args")); - register "clock-format" (fun args -> - match args with - | [Integer t] | [Integer t; String _] -> - 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 format_tm tm tz_label = + fun fmt -> let buf = Buffer.create 32 in let n = String.length fmt in let i = ref 0 in @@ -3411,14 +3547,19 @@ let () = 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)) + | 'y' -> Buffer.add_string buf (Printf.sprintf "%02d" ((1900 + tm.Unix.tm_year) mod 100)) | '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) + | 'I' -> let h = tm.Unix.tm_hour mod 12 in + Buffer.add_string buf (Printf.sprintf "%02d" (if h = 0 then 12 else h)) + | 'p' -> Buffer.add_string buf (if tm.Unix.tm_hour < 12 then "AM" else "PM") | '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" + | 'w' -> Buffer.add_string buf (string_of_int tm.Unix.tm_wday) + | 'Z' -> Buffer.add_string buf tz_label | '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 @@ -3427,6 +3568,7 @@ let () = 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) + | '%' -> Buffer.add_char buf '%' | c -> Buffer.add_char buf '%'; Buffer.add_char buf c); i := !i + 2 end else begin @@ -3434,8 +3576,100 @@ let () = incr i end done; - String (Buffer.contents buf) - | _ -> raise (Eval_error "clock-format: (seconds [format])")); + Buffer.contents buf + in + register "clock-format" (fun args -> + let (t, fmt, tz) = match args with + | [Integer t] -> (t, "%a %b %e %H:%M:%S %Z %Y", "utc") + | [Integer t; String f] -> (t, f, "utc") + | [Integer t; String f; String z] -> (t, f, z) + | _ -> raise (Eval_error "clock-format: (seconds [format [tz]])") + in + let tm = + if tz = "local" then Unix.localtime (float_of_int t) + else Unix.gmtime (float_of_int t) + in + let label = if tz = "local" then "" else "UTC" in + String (format_tm tm label fmt)); + + (* clock-scan: parse a date string with format, return seconds. + Supports the same format specifiers as clock-format (fixed-width ones). + tz: "utc" (default) or "local". *) + let timegm (tm : Unix.tm) = + let is_leap y = y mod 4 = 0 && (y mod 100 <> 0 || y mod 400 = 0) in + let days_in_month = [|31;28;31;30;31;30;31;31;30;31;30;31|] in + let year = tm.Unix.tm_year + 1900 in + let mon = tm.Unix.tm_mon in + let mday = tm.Unix.tm_mday in + let total_days = ref 0 in + if year >= 1970 then begin + for y = 1970 to year - 1 do + total_days := !total_days + (if is_leap y then 366 else 365) + done + end else begin + for y = year to 1969 do + total_days := !total_days - (if is_leap y then 366 else 365) + done + end; + for m = 0 to mon - 1 do + total_days := !total_days + days_in_month.(m); + if m = 1 && is_leap year then incr total_days + done; + total_days := !total_days + mday - 1; + !total_days * 86400 + + tm.Unix.tm_hour * 3600 + + tm.Unix.tm_min * 60 + + tm.Unix.tm_sec + in + register "clock-scan" (fun args -> + let (str, fmt, tz) = match args with + | [String s; String f] -> (s, f, "utc") + | [String s; String f; String z] -> (s, f, z) + | _ -> raise (Eval_error "clock-scan: (str fmt [tz])") + in + let n = String.length fmt and sn = String.length str in + let tm = ref { Unix.tm_year = 70; tm_mon = 0; tm_mday = 1; + tm_hour = 0; tm_min = 0; tm_sec = 0; + tm_wday = 0; tm_yday = 0; tm_isdst = false } in + let i = ref 0 and j = ref 0 in + let read_n_digits k = + let s = ref "" in + let cnt = ref 0 in + while !cnt < k && !j < sn && str.[!j] >= '0' && str.[!j] <= '9' do + s := !s ^ String.make 1 str.[!j]; + incr j; incr cnt + done; + if !s = "" then 0 else int_of_string !s + in + let skip_ws () = + while !j < sn && (str.[!j] = ' ' || str.[!j] = '\t') do incr j done + in + while !i < n do + if fmt.[!i] = '%' && !i + 1 < n then begin + (match fmt.[!i + 1] with + | 'Y' -> tm := { !tm with tm_year = read_n_digits 4 - 1900 } + | 'y' -> let y = read_n_digits 2 in + tm := { !tm with tm_year = (if y < 70 then 100 + y else y) } + | 'm' -> tm := { !tm with tm_mon = read_n_digits 2 - 1 } + | 'd' | 'e' -> skip_ws (); tm := { !tm with tm_mday = read_n_digits 2 } + | 'H' | 'I' -> tm := { !tm with tm_hour = read_n_digits 2 } + | 'M' -> tm := { !tm with tm_min = read_n_digits 2 } + | 'S' -> tm := { !tm with tm_sec = read_n_digits 2 } + | '%' -> if !j < sn && str.[!j] = '%' then incr j + | _ -> () (* unsupported specifier — skip *) + ); + i := !i + 2 + end else begin + if fmt.[!i] = ' ' then skip_ws () + else if !j < sn && str.[!j] = fmt.[!i] then incr j; + incr i + end + done; + let secs = + if tz = "local" then int_of_float (fst (Unix.mktime !tm)) + else timegm !tm + in + Integer secs); (* === Env-as-value (Phase 4) === *) diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index 727a94b2..e72928aa 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -292,13 +292,15 @@ (> (len result-stack) caller-stack-len) (nth result-stack caller-stack-len) (get interp :frame)))) - (assoc interp + ; Forward result-interp as base so state changes inside + ; the proc (e.g. :fileevents, :timers, :procs) propagate; + ; restore caller's frame/stack/result/output/code. + (assoc result-interp :frame updated-caller :frame-stack updated-below :result result-val :output (str caller-output proc-output) - :code (if (= code 2) 0 code) - :commands (get result-interp :commands)))))))))))))) + :code (if (= code 2) 0 code)))))))))))))) (define tcl-eval-cmd @@ -2887,12 +2889,54 @@ ((equal? sub "seconds") (assoc interp :result (str (clock-seconds)))) ((equal? sub "milliseconds") (assoc interp :result (str (clock-milliseconds)))) ((equal? sub "format") - (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")) + ; clock format $secs ?-format $fmt? ?-timezone $tz? ?-gmt 0|1? + (let + ((t (floor (parse-int (first rest-args)))) + (opts (rest rest-args))) + (let + ((fmt (tcl-clock-opt opts "-format" "%a %b %e %H:%M:%S %Z %Y")) + (tz (tcl-clock-tz opts))) + (assoc interp :result (clock-format t fmt tz))))) + ((equal? sub "scan") + ; clock scan $str ?-format $fmt? ?-timezone $tz? ?-gmt 0|1? + (let + ((s (first rest-args)) (opts (rest rest-args))) + (let + ((fmt (tcl-clock-opt opts "-format" "%Y-%m-%d %H:%M:%S")) + (tz (tcl-clock-tz opts))) + (assoc interp :result (str (clock-scan s fmt tz)))))) (else (error (str "clock: unknown subcommand \"" sub "\"")))))))) +; Helper: extract a -flag $val pair from clock args. +(define + tcl-clock-opt + (fn + (opts flag default) + (cond + ((< (len opts) 2) default) + ((equal? (first opts) flag) (nth opts 1)) + (else (tcl-clock-opt (rest (rest opts)) flag default))))) + +; Helper: derive tz string from clock opts (-timezone or -gmt). +(define + tcl-clock-tz + (fn + (opts) + (let + ((tz-explicit (tcl-clock-opt opts "-timezone" nil)) + (gmt-flag (tcl-clock-opt opts "-gmt" nil))) + (cond + ((not (nil? tz-explicit)) + (cond + ((equal? tz-explicit ":UTC") "utc") + ((equal? tz-explicit "UTC") "utc") + ((equal? tz-explicit "GMT") "utc") + (else "local"))) + ((equal? gmt-flag "1") "utc") + ((equal? gmt-flag "true") "utc") + ((not (nil? gmt-flag)) "local") + (else "utc"))))) + (define tcl-cmd-open (fn @@ -2973,26 +3017,31 @@ (interp args) (let ((chan (first args)) (rest-args (rest args))) - (if - (= 0 (len rest-args)) - (assoc - interp - :result (str "-blocking " (if (channel-blocking? chan) "1" "0"))) - (if - (and - (= 2 (len rest-args)) - (equal? (first rest-args) "-blocking")) + (cond + ((= 0 (len rest-args)) + (assoc + interp + :result (str "-blocking " (if (channel-blocking? chan) "1" "0")))) + ((and + (= 2 (len rest-args)) + (equal? (first rest-args) "-blocking")) (let ((b (nth rest-args 1))) (let - ((_ (channel-set-blocking! chan (not (or (equal? b "0") (equal? b "false")))))) - (assoc interp :result ""))) - (if - (and - (= 1 (len rest-args)) - (equal? (first rest-args) "-blocking")) - (assoc interp :result (if (channel-blocking? chan) "1" "0")) - (assoc interp :result ""))))))) + ((_ + (channel-set-blocking! + chan + (not (or (equal? b "0") (equal? b "false")))))) + (assoc interp :result "")))) + ((and + (= 1 (len rest-args)) + (equal? (first rest-args) "-blocking")) + (assoc interp :result (if (channel-blocking? chan) "1" "0"))) + ((and + (= 1 (len rest-args)) + (equal? (first rest-args) "-error")) + (assoc interp :result (channel-async-error chan))) + (else (assoc interp :result "")))))) ; ============================================================ @@ -3253,6 +3302,13 @@ (assoc (tcl-fileevent-set interp server-chan "readable" handler) :result server-chan)))))) + ((equal? (first args) "-async") + (if + (< (len args) 3) + (error "socket: usage: socket -async host port") + (let + ((host (nth args 1)) (port (parse-int (nth args 2)))) + (assoc interp :result (socket-connect-async host port))))) ((= 2 (len args)) (let ((host (first args)) (port (parse-int (nth args 1)))) @@ -3609,16 +3665,52 @@ (equal? dot-idx "-1") nm (substring nm 0 (parse-int dot-idx))))))) - ((equal? sub "isfile") (assoc interp :result "0")) - ((equal? sub "isdir") (assoc interp :result "0")) - ((equal? sub "isdirectory") (assoc interp :result "0")) - ((equal? sub "readable") (assoc interp :result "0")) - ((equal? sub "writable") (assoc interp :result "0")) - ((equal? sub "size") (assoc interp :result "0")) - ((equal? sub "mkdir") (assoc interp :result "")) - ((equal? sub "copy") (assoc interp :result "")) - ((equal? sub "rename") (assoc interp :result "")) - ((equal? sub "delete") (assoc interp :result "")) + ((equal? sub "isfile") + (assoc interp :result (if (file-isfile? (first rest-args)) "1" "0"))) + ((equal? sub "isdir") + (assoc interp :result (if (file-isdir? (first rest-args)) "1" "0"))) + ((equal? sub "isdirectory") + (assoc interp :result (if (file-isdir? (first rest-args)) "1" "0"))) + ((equal? sub "readable") + (assoc interp :result (if (file-readable? (first rest-args)) "1" "0"))) + ((equal? sub "writable") + (assoc interp :result (if (file-writable? (first rest-args)) "1" "0"))) + ((equal? sub "size") + (assoc interp :result (str (file-size (first rest-args))))) + ((equal? sub "mtime") + (assoc interp :result (str (file-mtime (first rest-args))))) + ((equal? sub "atime") + (let ((s (file-stat (first rest-args)))) + (assoc interp :result (if (nil? s) "0" (str (get s :atime)))))) + ((equal? sub "type") + (let ((s (file-stat (first rest-args)))) + (assoc interp :result (if (nil? s) "" (get s :type))))) + ((equal? sub "mkdir") + (let ((_ (file-mkdir (first rest-args)))) + (assoc interp :result ""))) + ((equal? sub "copy") + (let + ((paths + (filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args))) + (let ((_ (file-copy (first paths) (nth paths 1)))) + (assoc interp :result "")))) + ((equal? sub "rename") + (let + ((paths + (filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args))) + (let ((_ (file-rename (first paths) (nth paths 1)))) + (assoc interp :result "")))) + ((equal? sub "delete") + (let + ((paths + (filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args))) + (let + ((_ + (reduce + (fn (acc p) (let ((_ (file-delete p))) acc)) + nil + paths))) + (assoc interp :result "")))) (else (error (str "file: unknown subcommand \"" sub "\"")))))))) (define diff --git a/lib/tcl/test.sh b/lib/tcl/test.sh index c36a9440..fbf1f7e5 100755 --- a/lib/tcl/test.sh +++ b/lib/tcl/test.sh @@ -57,7 +57,7 @@ cat > "$TMPFILE" << EPOCHS (eval "tcl-test-summary") EPOCHS -OUTPUT=$(timeout 1200 "$SX_SERVER" < "$TMPFILE" 2>&1) +OUTPUT=$(timeout 2400 "$SX_SERVER" < "$TMPFILE" 2>&1) [ "$VERBOSE" = "-v" ] && echo "$OUTPUT" # Extract summary line from epoch 11 output diff --git a/lib/tcl/tests/idioms.sx b/lib/tcl/tests/idioms.sx index a49866e2..b6df6180 100644 --- a/lib/tcl/tests/idioms.sx +++ b/lib/tcl/tests/idioms.sx @@ -303,6 +303,118 @@ :result) "3") + ; 42-49. Phase 5d file metadata + ops + (ok "file-isfile-true" + (get + (run + "set f /tmp/tcl-phase5d-1.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset r [file isfile $f]\nfile delete $f\nreturn $r") + :result) + "1") + + (ok "file-isfile-false-on-dir" + (get (run "file isfile /tmp") :result) + "0") + + (ok "file-isdir-true" + (get (run "file isdir /tmp") :result) + "1") + + (ok "file-size" + (get + (run + "set f /tmp/tcl-phase5d-2.txt\nset c [open $f w]\nputs -nonewline $c hello\nclose $c\nset s [file size $f]\nfile delete $f\nreturn $s") + :result) + "5") + + (ok "file-readable-true" + (get (run "file readable /tmp") :result) + "1") + + (ok "file-readable-missing" + (get (run "file readable /no/such/path/here") :result) + "0") + + (ok "file-mkdir-then-isdir" + (get + (run + "set d /tmp/tcl-phase5d-mkdir/sub\nfile mkdir $d\nset r [file isdir $d]\nfile delete $d\nfile delete /tmp/tcl-phase5d-mkdir\nreturn $r") + :result) + "1") + + (ok "file-copy-roundtrip" + (get + (run + "set s /tmp/tcl-phase5d-src.txt\nset d /tmp/tcl-phase5d-dst.txt\nset c [open $s w]\nputs -nonewline $c copydata\nclose $c\nfile copy $s $d\nset c [open $d r]\nset out [read $c]\nclose $c\nfile delete $s\nfile delete $d\nreturn $out") + :result) + "copydata") + + (ok "file-rename-then-exists" + (get + (run + "set s /tmp/tcl-phase5d-r1.txt\nset d /tmp/tcl-phase5d-r2.txt\nset c [open $s w]\nputs -nonewline $c x\nclose $c\nfile rename $s $d\nset r [list [file exists $s] [file exists $d]]\nfile delete $d\nreturn $r") + :result) + "0 1") + + (ok "file-mtime-positive" + (get + (run + "set f /tmp/tcl-phase5d-mt.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset m [file mtime $f]\nfile delete $f\nexpr {$m > 0}") + :result) + "1") + + ; 52-56. Phase 5e clock format options + clock scan + (ok "clock-format-utc" + (get + (run "clock format 0 -format {%Y-%m-%d %H:%M:%S} -gmt 1") + :result) + "1970-01-01 00:00:00") + + (ok "clock-format-fmt-default" + (get + (run "clock format 1710513000 -format {%Y-%m-%d} -gmt 1") + :result) + "2024-03-15") + + (ok "clock-scan-roundtrip" + (get + (run "set t [clock scan {2024-06-15 12:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1]\nclock format $t -format {%Y-%m-%d %H:%M:%S} -gmt 1") + :result) + "2024-06-15 12:00:00") + + (ok "clock-scan-returns-int" + (get + (run "expr {[clock scan {1970-01-01 00:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1] == 0}") + :result) + "1") + + (ok "clock-format-percent-pct" + (get + (run "clock format 0 -format {%Y%%%m} -gmt 1") + :result) + "1970%01") + + ; 57-59. Phase 5f socket -async (non-blocking connect) + (ok "socket-async-completes-writable" + (get + (run + "proc h {sock host port} { close $sock }\nset srv [socket -server h 18930]\nset c [socket -async localhost 18930]\nset ready 0\nfileevent $c writable {global ready; set ready 1}\nvwait ready\nclose $c\nclose $srv\nset ready") + :result) + "1") + + (ok "socket-async-then-write" + (get + (run + "proc accept {sock host port} { global accepted_sock; set accepted_sock $sock; fileevent $sock readable [list reader $sock] }\nproc reader {sock} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server accept 18931]\nset c [socket -async localhost 18931]\nfileevent $c writable {global wready; set wready 1; fileevent $::ch writable {}}\nset ::ch $c\nvwait wready\nputs $c async-data\nflush $c\nvwait received\nclose $c\nclose $srv\nset received") + :result) + "async-data") + + (ok "socket-async-no-error" + (get + (run + "proc h {sock host port} { close $sock }\nset srv [socket -server h 18932]\nset c [socket -async localhost 18932]\nset r 0\nfileevent $c writable {global r; set r 1}\nvwait r\nset err [fconfigure $c -error]\nclose $c\nclose $srv\nreturn $err") + :result) + "") + (dict "passed" tcl-idiom-pass