Merge remote-tracking branch 'origin/loops/tcl' into architecture
This commit is contained in:
@@ -3124,6 +3124,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
|
||||
@@ -3337,6 +3439,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)
|
||||
@@ -3432,11 +3571,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
|
||||
@@ -3444,14 +3580,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
|
||||
@@ -3460,6 +3601,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
|
||||
@@ -3467,8 +3609,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) === *)
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -59,7 +59,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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user