tcl: Phase 5 channel I/O — open/read/gets/puts/seek/tell/eof/fconfigure
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 2m0s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 2m0s
11 new SX primitives in sx_primitives.ml wrapping Unix.openfile/read/write/ lseek/set_nonblock: channel-open/close/read/read-line/write/flush/seek/tell/ eof?/blocking?/set-blocking!. Tcl runtime now uses real channel ops: - open ?-mode? returns "fileN" handle (modes r/w/a/r+/w+/a+) - close/read/gets/puts/seek/tell/eof/flush wired through - new fconfigure command supports -blocking 0|1 - puts dispatches to channel-write when first arg starts with "file" - gets command registration fixed (was pointing to old stub) eof-returns-1 coro test updated to match real Tcl semantics (eof flips only after a read hits EOF). Test runner timeout bumped 180s→1200s (post-merge JIT is slow). +7 idiom tests covering write+read, gets-loop, seek/tell, eof-after-read, append mode, seek-to-end, fconfigure-blocking. 349/349 green. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
@@ -354,14 +354,28 @@
|
||||
(fn
|
||||
(interp args)
|
||||
(let
|
||||
((text (last args))
|
||||
(no-nl
|
||||
(and
|
||||
(> (len args) 1)
|
||||
(equal? (first args) "-nonewline"))))
|
||||
((no-nl (and (> (len args) 1) (equal? (first args) "-nonewline"))))
|
||||
(let
|
||||
((line (if no-nl text (str text "\n"))))
|
||||
(assoc interp :output (str (get interp :output) line))))))
|
||||
((args2 (if no-nl (rest args) args)))
|
||||
(let
|
||||
((maybe-chan (if (> (len args2) 1) (first args2) nil))
|
||||
(is-chan
|
||||
(and
|
||||
(not (nil? maybe-chan))
|
||||
(>= (len maybe-chan) 4)
|
||||
(equal? (slice maybe-chan 0 4) "file"))))
|
||||
(if
|
||||
is-chan
|
||||
(let
|
||||
((chan (first args2))
|
||||
(text (last args2))
|
||||
(line (if no-nl text (str text "\n"))))
|
||||
(let
|
||||
((_ (channel-write chan line)))
|
||||
(assoc interp :result "")))
|
||||
(let
|
||||
((text (last args2)) (line (if no-nl text (str text "\n"))))
|
||||
(assoc interp :output (str (get interp :output) line)))))))))
|
||||
|
||||
(define
|
||||
tcl-cmd-incr
|
||||
@@ -2874,30 +2888,108 @@
|
||||
((equal? sub "scan") (assoc interp :result "0"))
|
||||
(else (error (str "clock: unknown subcommand \"" sub "\""))))))))
|
||||
|
||||
(define tcl-cmd-open (fn (interp args) (assoc interp :result "file0")))
|
||||
(define
|
||||
tcl-cmd-open
|
||||
(fn
|
||||
(interp args)
|
||||
(let
|
||||
((path (first args))
|
||||
(mode (if (> (len args) 1) (nth args 1) "r")))
|
||||
(assoc interp :result (channel-open path mode)))))
|
||||
|
||||
; gets channel ?varname?
|
||||
(define tcl-cmd-close (fn (interp args) (assoc interp :result "")))
|
||||
(define
|
||||
tcl-cmd-close
|
||||
(fn
|
||||
(interp args)
|
||||
(let ((_ (channel-close (first args)))) (assoc interp :result ""))))
|
||||
|
||||
(define tcl-cmd-read (fn (interp args) (assoc interp :result "")))
|
||||
(define
|
||||
tcl-cmd-read
|
||||
(fn
|
||||
(interp args)
|
||||
(let
|
||||
((chan (first args))
|
||||
(n (if (> (len args) 1) (parse-int (nth args 1)) -1)))
|
||||
(assoc
|
||||
interp
|
||||
:result (if (< n 0) (channel-read chan) (channel-read chan n))))))
|
||||
|
||||
(define
|
||||
tcl-cmd-gets-chan
|
||||
(fn
|
||||
(interp args)
|
||||
(if
|
||||
(> (len args) 1)
|
||||
(assoc (tcl-var-set interp (nth args 1) "") :result "-1")
|
||||
(assoc interp :result ""))))
|
||||
(let
|
||||
((chan (first args)) (line (channel-read-line chan)))
|
||||
(if
|
||||
(nil? line)
|
||||
(if
|
||||
(> (len args) 1)
|
||||
(assoc (tcl-var-set interp (nth args 1) "") :result "-1")
|
||||
(assoc interp :result ""))
|
||||
(if
|
||||
(> (len args) 1)
|
||||
(assoc
|
||||
(tcl-var-set interp (nth args 1) line)
|
||||
:result (str (len line)))
|
||||
(assoc interp :result line))))))
|
||||
|
||||
(define tcl-cmd-eof (fn (interp args) (assoc interp :result "1")))
|
||||
(define
|
||||
tcl-cmd-eof
|
||||
(fn
|
||||
(interp args)
|
||||
(assoc interp :result (if (channel-eof? (first args)) "1" "0"))))
|
||||
|
||||
(define tcl-cmd-seek (fn (interp args) (assoc interp :result "")))
|
||||
(define
|
||||
tcl-cmd-seek
|
||||
(fn
|
||||
(interp args)
|
||||
(let
|
||||
((chan (first args))
|
||||
(off (parse-int (nth args 1)))
|
||||
(whence (if (> (len args) 2) (nth args 2) "start")))
|
||||
(let ((_ (channel-seek chan off whence))) (assoc interp :result "")))))
|
||||
|
||||
; file command dispatcher
|
||||
(define tcl-cmd-tell (fn (interp args) (assoc interp :result "0")))
|
||||
(define
|
||||
tcl-cmd-tell
|
||||
(fn
|
||||
(interp args)
|
||||
(assoc interp :result (str (channel-tell (first args))))))
|
||||
|
||||
(define
|
||||
tcl-cmd-flush
|
||||
(fn
|
||||
(interp args)
|
||||
(let ((_ (channel-flush (first args)))) (assoc interp :result ""))))
|
||||
(define
|
||||
tcl-cmd-fconfigure
|
||||
(fn
|
||||
(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"))
|
||||
(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 "")))))))
|
||||
|
||||
|
||||
(define tcl-cmd-flush (fn (interp args) (assoc interp :result "")))
|
||||
(define
|
||||
tcl-cmd-array
|
||||
(fn
|
||||
@@ -2909,11 +3001,16 @@
|
||||
((sub (first args)) (rest-args (rest args)))
|
||||
(cond
|
||||
((equal? sub "get")
|
||||
(if (= 0 (len rest-args))
|
||||
(if
|
||||
(= 0 (len rest-args))
|
||||
(error "array get: wrong # args")
|
||||
(let
|
||||
((arr-name (first rest-args))
|
||||
(pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
|
||||
(pattern
|
||||
(if
|
||||
(> (len rest-args) 1)
|
||||
(nth rest-args 1)
|
||||
nil)))
|
||||
(let
|
||||
((prefix (str arr-name "("))
|
||||
(locals (get (get interp :frame) :locals)))
|
||||
@@ -2922,21 +3019,20 @@
|
||||
(let
|
||||
((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))
|
||||
(let
|
||||
((filtered
|
||||
(if
|
||||
(nil? pattern)
|
||||
arr-keys
|
||||
(filter
|
||||
(fn (k)
|
||||
(let ((kn (substring k pl (- (string-length k) 1))))
|
||||
(tcl-glob-match (split pattern "") (split kn ""))))
|
||||
arr-keys))))
|
||||
(assoc interp :result
|
||||
(join " "
|
||||
((filtered (if (nil? pattern) arr-keys (filter (fn (k) (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) arr-keys))))
|
||||
(assoc
|
||||
interp
|
||||
:result (join
|
||||
" "
|
||||
(reduce
|
||||
(fn (acc k)
|
||||
(let ((kn (substring k pl (- (string-length k) 1))))
|
||||
(append acc (list kn) (list (get locals k)))))
|
||||
(fn
|
||||
(acc k)
|
||||
(let
|
||||
((kn (substring k pl (- (string-length k) 1))))
|
||||
(append
|
||||
acc
|
||||
(list kn)
|
||||
(list (get locals k)))))
|
||||
(list)
|
||||
filtered))))))))))
|
||||
((equal? sub "set")
|
||||
@@ -2954,7 +3050,8 @@
|
||||
(assoc acc :result "")
|
||||
(loop
|
||||
(rest (rest pairs))
|
||||
(tcl-var-set acc
|
||||
(tcl-var-set
|
||||
acc
|
||||
(str arr-name "(" (first pairs) ")")
|
||||
(nth pairs 1))))))))
|
||||
((equal? sub "names")
|
||||
@@ -2963,7 +3060,11 @@
|
||||
(error "array names: wrong # args")
|
||||
(let
|
||||
((arr-name (first rest-args))
|
||||
(pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
|
||||
(pattern
|
||||
(if
|
||||
(> (len rest-args) 1)
|
||||
(nth rest-args 1)
|
||||
nil)))
|
||||
(let
|
||||
((prefix (str arr-name "("))
|
||||
(locals (get (get interp :frame) :locals)))
|
||||
@@ -2972,17 +3073,19 @@
|
||||
(let
|
||||
((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))
|
||||
(let
|
||||
((filtered
|
||||
(if
|
||||
(nil? pattern)
|
||||
arr-keys
|
||||
(filter
|
||||
(fn (k)
|
||||
(let ((kn (substring k pl (- (string-length k) 1))))
|
||||
(tcl-glob-match (split pattern "") (split kn ""))))
|
||||
arr-keys))))
|
||||
(assoc interp :result
|
||||
(join " " (map (fn (k) (substring k pl (- (string-length k) 1))) filtered))))))))))
|
||||
((filtered (if (nil? pattern) arr-keys (filter (fn (k) (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) arr-keys))))
|
||||
(assoc
|
||||
interp
|
||||
:result (join
|
||||
" "
|
||||
(map
|
||||
(fn
|
||||
(k)
|
||||
(substring
|
||||
k
|
||||
pl
|
||||
(- (string-length k) 1)))
|
||||
filtered))))))))))
|
||||
((equal? sub "size")
|
||||
(if
|
||||
(= 0 (len rest-args))
|
||||
@@ -2990,8 +3093,13 @@
|
||||
(let
|
||||
((prefix (str (first rest-args) "("))
|
||||
(locals (get (get interp :frame) :locals)))
|
||||
(assoc interp :result
|
||||
(str (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))))))
|
||||
(assoc
|
||||
interp
|
||||
:result (str
|
||||
(len
|
||||
(filter
|
||||
(fn (k) (tcl-starts-with? k prefix))
|
||||
(keys locals))))))))
|
||||
((equal? sub "exists")
|
||||
(if
|
||||
(= 0 (len rest-args))
|
||||
@@ -2999,44 +3107,39 @@
|
||||
(let
|
||||
((prefix (str (first rest-args) "("))
|
||||
(locals (get (get interp :frame) :locals)))
|
||||
(assoc interp :result
|
||||
(if (> (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))) 0) "1" "0")))))
|
||||
(assoc
|
||||
interp
|
||||
:result (if
|
||||
(>
|
||||
(len
|
||||
(filter
|
||||
(fn (k) (tcl-starts-with? k prefix))
|
||||
(keys locals)))
|
||||
0)
|
||||
"1"
|
||||
"0")))))
|
||||
((equal? sub "unset")
|
||||
(if
|
||||
(= 0 (len rest-args))
|
||||
(error "array unset: wrong # args")
|
||||
(let
|
||||
((arr-name (first rest-args))
|
||||
(pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
|
||||
(pattern
|
||||
(if
|
||||
(> (len rest-args) 1)
|
||||
(nth rest-args 1)
|
||||
nil)))
|
||||
(let
|
||||
((prefix (str arr-name "("))
|
||||
(locals (get (get interp :frame) :locals)))
|
||||
(let
|
||||
((pl (string-length prefix)))
|
||||
(let
|
||||
((to-delete
|
||||
(filter
|
||||
(fn (k)
|
||||
(if
|
||||
(tcl-starts-with? k prefix)
|
||||
(if
|
||||
(nil? pattern)
|
||||
true
|
||||
(let ((kn (substring k pl (- (string-length k) 1))))
|
||||
(tcl-glob-match (split pattern "") (split kn ""))))
|
||||
false))
|
||||
(keys locals))))
|
||||
((to-delete (filter (fn (k) (if (tcl-starts-with? k prefix) (if (nil? pattern) true (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) false)) (keys locals))))
|
||||
(let
|
||||
((new-locals
|
||||
(reduce
|
||||
(fn (acc k)
|
||||
(if
|
||||
(contains? to-delete k)
|
||||
acc
|
||||
(assoc acc k (get locals k))))
|
||||
{}
|
||||
(keys locals))))
|
||||
(assoc interp
|
||||
((new-locals (reduce (fn (acc k) (if (contains? to-delete k) acc (assoc acc k (get locals k)))) {} (keys locals))))
|
||||
(assoc
|
||||
interp
|
||||
:frame (assoc (get interp :frame) :locals new-locals)
|
||||
:result ""))))))))
|
||||
(else (error (str "array: unknown subcommand \"" sub "\""))))))))
|
||||
@@ -3048,7 +3151,7 @@
|
||||
(interp args)
|
||||
(if
|
||||
(< (len args) 1)
|
||||
(error "apply: wrong # args: should be "apply lambdaList ?arg ...?"")
|
||||
(error "apply: wrong # args: should be " apply lambdaList ?arg ...? "")
|
||||
(let
|
||||
((func-list (tcl-list-split (first args)))
|
||||
(call-args (rest args)))
|
||||
@@ -3058,90 +3161,122 @@
|
||||
(let
|
||||
((param-spec (first func-list))
|
||||
(body (nth func-list 1))
|
||||
(ns (if (> (len func-list) 2) (nth func-list 2) nil)))
|
||||
(ns
|
||||
(if
|
||||
(> (len func-list) 2)
|
||||
(nth func-list 2)
|
||||
nil)))
|
||||
(let
|
||||
((proc-def {:args param-spec :body body :ns ns}))
|
||||
(tcl-call-proc interp "#apply" proc-def call-args))))))))
|
||||
|
||||
|
||||
(define
|
||||
tcl-cmd-regexp
|
||||
(fn
|
||||
(interp args)
|
||||
(define parse-flags
|
||||
(fn (as nocase? all? inline?)
|
||||
(if (= 0 (len as))
|
||||
{:nocase nocase? :all all? :inline inline? :rest as}
|
||||
(define
|
||||
parse-flags
|
||||
(fn
|
||||
(as nocase? all? inline?)
|
||||
(if
|
||||
(= 0 (len as))
|
||||
{:rest as :nocase nocase? :inline inline? :all all?}
|
||||
(cond
|
||||
((equal? (first as) "-nocase") (parse-flags (rest as) true all? inline?))
|
||||
((equal? (first as) "-all") (parse-flags (rest as) nocase? true inline?))
|
||||
((equal? (first as) "-inline") (parse-flags (rest as) nocase? all? true))
|
||||
(else {:nocase nocase? :all all? :inline inline? :rest as})))))
|
||||
(let ((pf (parse-flags args false false false)))
|
||||
(let ((nocase (get pf :nocase))
|
||||
(all-mode (get pf :all))
|
||||
(inline-mode (get pf :inline))
|
||||
(ra (get pf :rest)))
|
||||
(if (< (len ra) 2)
|
||||
((equal? (first as) "-nocase")
|
||||
(parse-flags (rest as) true all? inline?))
|
||||
((equal? (first as) "-all")
|
||||
(parse-flags (rest as) nocase? true inline?))
|
||||
((equal? (first as) "-inline")
|
||||
(parse-flags (rest as) nocase? all? true))
|
||||
(else {:rest as :nocase nocase? :inline inline? :all all?})))))
|
||||
(let
|
||||
((pf (parse-flags args false false false)))
|
||||
(let
|
||||
((nocase (get pf :nocase))
|
||||
(all-mode (get pf :all))
|
||||
(inline-mode (get pf :inline))
|
||||
(ra (get pf :rest)))
|
||||
(if
|
||||
(< (len ra) 2)
|
||||
(error "regexp: wrong # args")
|
||||
(let ((pattern (first ra))
|
||||
(str-val (nth ra 1))
|
||||
(var-args (if (> (len ra) 2) (rest (rest ra)) (list))))
|
||||
(let ((re (make-regexp pattern (if nocase "i" ""))))
|
||||
(if all-mode
|
||||
(assoc interp :result (str (len (regexp-match-all re str-val))))
|
||||
(if inline-mode
|
||||
(assoc interp :result (join " " (map (fn (m) (get m :match)) (regexp-match-all re str-val))))
|
||||
(let ((m (regexp-match re str-val)))
|
||||
(if (nil? m)
|
||||
(let
|
||||
((pattern (first ra))
|
||||
(str-val (nth ra 1))
|
||||
(var-args
|
||||
(if (> (len ra) 2) (rest (rest ra)) (list))))
|
||||
(let
|
||||
((re (make-regexp pattern (if nocase "i" ""))))
|
||||
(if
|
||||
all-mode
|
||||
(assoc
|
||||
interp
|
||||
:result (str (len (regexp-match-all re str-val))))
|
||||
(if
|
||||
inline-mode
|
||||
(assoc
|
||||
interp
|
||||
:result (join
|
||||
" "
|
||||
(map
|
||||
(fn (m) (get m :match))
|
||||
(regexp-match-all re str-val))))
|
||||
(let
|
||||
((m (regexp-match re str-val)))
|
||||
(if
|
||||
(nil? m)
|
||||
(assoc interp :result "0")
|
||||
(let ((interp2
|
||||
(if (> (len var-args) 0)
|
||||
(tcl-var-set interp (first var-args) (get m :match))
|
||||
interp)))
|
||||
(let ((interp3
|
||||
(let loop ((vi 1) (gs (get m :groups)) (acc interp2))
|
||||
(if (or (= 0 (len gs)) (>= vi (len var-args))) acc
|
||||
(loop (+ vi 1) (rest gs)
|
||||
(tcl-var-set acc (nth var-args vi) (first gs)))))))
|
||||
(let
|
||||
((interp2 (if (> (len var-args) 0) (tcl-var-set interp (first var-args) (get m :match)) interp)))
|
||||
(let
|
||||
((interp3 (let loop ((vi 1) (gs (get m :groups)) (acc interp2)) (if (or (= 0 (len gs)) (>= vi (len var-args))) acc (loop (+ vi 1) (rest gs) (tcl-var-set acc (nth var-args vi) (first gs)))))))
|
||||
(assoc interp3 :result "1"))))))))))))))
|
||||
|
||||
|
||||
|
||||
(define
|
||||
tcl-cmd-regsub
|
||||
(fn
|
||||
(interp args)
|
||||
(define parse-flags
|
||||
(fn (as all? nocase?)
|
||||
(if (= 0 (len as))
|
||||
{:all all? :nocase nocase? :rest as}
|
||||
(define
|
||||
parse-flags
|
||||
(fn
|
||||
(as all? nocase?)
|
||||
(if
|
||||
(= 0 (len as))
|
||||
{:rest as :nocase nocase? :all all?}
|
||||
(cond
|
||||
((equal? (first as) "-all") (parse-flags (rest as) true nocase?))
|
||||
((equal? (first as) "-nocase") (parse-flags (rest as) all? true))
|
||||
(else {:all all? :nocase nocase? :rest as})))))
|
||||
(let ((pf (parse-flags args false false)))
|
||||
(let ((all-mode (get pf :all))
|
||||
(nocase (get pf :nocase))
|
||||
(ra (get pf :rest)))
|
||||
(if (< (len ra) 3)
|
||||
((equal? (first as) "-all")
|
||||
(parse-flags (rest as) true nocase?))
|
||||
((equal? (first as) "-nocase")
|
||||
(parse-flags (rest as) all? true))
|
||||
(else {:rest as :nocase nocase? :all all?})))))
|
||||
(let
|
||||
((pf (parse-flags args false false)))
|
||||
(let
|
||||
((all-mode (get pf :all))
|
||||
(nocase (get pf :nocase))
|
||||
(ra (get pf :rest)))
|
||||
(if
|
||||
(< (len ra) 3)
|
||||
(error "regsub: wrong # args")
|
||||
(let ((pattern (first ra))
|
||||
(str-val (nth ra 1))
|
||||
(replacement (nth ra 2))
|
||||
(var-name (if (> (len ra) 3) (nth ra 3) nil)))
|
||||
(let ((re (make-regexp pattern (if nocase "i" ""))))
|
||||
(let ((result
|
||||
(if all-mode
|
||||
(regexp-replace-all re str-val replacement)
|
||||
(regexp-replace re str-val replacement))))
|
||||
(if (nil? var-name)
|
||||
(let
|
||||
((pattern (first ra))
|
||||
(str-val (nth ra 1))
|
||||
(replacement (nth ra 2))
|
||||
(var-name
|
||||
(if (> (len ra) 3) (nth ra 3) nil)))
|
||||
(let
|
||||
((re (make-regexp pattern (if nocase "i" ""))))
|
||||
(let
|
||||
((result (if all-mode (regexp-replace-all re str-val replacement) (regexp-replace re str-val replacement))))
|
||||
(if
|
||||
(nil? var-name)
|
||||
(assoc interp :result result)
|
||||
(let ((count
|
||||
(if all-mode
|
||||
(len (regexp-match-all re str-val))
|
||||
(if (nil? (regexp-match re str-val)) 0 1))))
|
||||
(assoc (tcl-var-set interp var-name result) :result (str count))))))))))))
|
||||
|
||||
|
||||
(let
|
||||
((count (if all-mode (len (regexp-match-all re str-val)) (if (nil? (regexp-match re str-val)) 0 1))))
|
||||
(assoc
|
||||
(tcl-var-set interp var-name result)
|
||||
:result (str count))))))))))))
|
||||
|
||||
(define
|
||||
tcl-cmd-file
|
||||
@@ -3153,7 +3288,10 @@
|
||||
(let
|
||||
((sub (first args)) (rest-args (rest args)))
|
||||
(cond
|
||||
((equal? sub "exists") (assoc interp :result (if (file-exists? (first rest-args)) "1" "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
|
||||
@@ -3254,7 +3392,7 @@
|
||||
(let
|
||||
((i (tcl-register i "expr" tcl-cmd-expr)))
|
||||
(let
|
||||
((i (tcl-register i "gets" tcl-cmd-gets)))
|
||||
((i (tcl-register i "gets" tcl-cmd-gets-chan)))
|
||||
(let
|
||||
((i (tcl-register i "subst" tcl-cmd-subst)))
|
||||
(let
|
||||
@@ -3331,6 +3469,17 @@
|
||||
((i (tcl-register i "tell" tcl-cmd-tell)))
|
||||
(let
|
||||
((i (tcl-register i "flush" tcl-cmd-flush)))
|
||||
(let ((i (tcl-register i "file" tcl-cmd-file)))
|
||||
(let ((i (tcl-register i "regexp" tcl-cmd-regexp)))
|
||||
(let ((i (tcl-register i "regsub" tcl-cmd-regsub))) (let ((i (tcl-register i "apply" tcl-cmd-apply))) (tcl-register i "array" tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
|
||||
(let
|
||||
((i (tcl-register i "fconfigure" tcl-cmd-fconfigure)))
|
||||
(let
|
||||
((i (tcl-register i "file" tcl-cmd-file)))
|
||||
(let
|
||||
((i (tcl-register i "regexp" tcl-cmd-regexp)))
|
||||
(let
|
||||
((i (tcl-register i "regsub" tcl-cmd-regsub)))
|
||||
(let
|
||||
((i (tcl-register i "apply" tcl-cmd-apply)))
|
||||
(tcl-register
|
||||
i
|
||||
"array"
|
||||
tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
|
||||
|
||||
@@ -57,7 +57,7 @@ cat > "$TMPFILE" << EPOCHS
|
||||
(eval "tcl-test-summary")
|
||||
EPOCHS
|
||||
|
||||
OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
OUTPUT=$(timeout 1200 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
|
||||
|
||||
# Extract summary line from epoch 11 output
|
||||
|
||||
@@ -124,7 +124,7 @@
|
||||
"file0")
|
||||
|
||||
(ok "eof-returns-1"
|
||||
(get (run "set ch [open /dev/null r]\neof $ch") :result)
|
||||
(get (run "set ch [open /dev/null r]\nread $ch\neof $ch") :result)
|
||||
"1")
|
||||
|
||||
(dict
|
||||
|
||||
@@ -187,6 +187,57 @@
|
||||
(env-extend (env-extend base "a" 3) "b" 7)
|
||||
(quote (* a b))))
|
||||
21)
|
||||
|
||||
; 26-32. Phase 5 channels: write/read/seek/tell/eof/append/non-blocking
|
||||
(ok "channel-write-read"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-1.txt\nset c [open $f w]\nputs $c \"line one\"\nputs $c \"line two\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out")
|
||||
:result)
|
||||
"line one\nline two\n")
|
||||
|
||||
(ok "channel-gets-loop"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-2.txt\nset c [open $f w]\nputs $c apple\nputs $c banana\nputs $c cherry\nclose $c\nset c [open $f r]\nset out {}\nwhile {[gets $c line] >= 0} {lappend out $line}\nclose $c\nfile delete $f\nreturn $out")
|
||||
:result)
|
||||
"apple banana cherry")
|
||||
|
||||
(ok "channel-seek-tell"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-3.txt\nset c [open $f w]\nputs -nonewline $c \"hello world\"\nclose $c\nset c [open $f r]\nseek $c 6\nset pos [tell $c]\nset rest [read $c]\nclose $c\nfile delete $f\nreturn \"$pos:$rest\"")
|
||||
:result)
|
||||
"6:world")
|
||||
|
||||
(ok "channel-eof-after-read"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-4.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset c [open $f r]\nread $c\nset e [eof $c]\nclose $c\nfile delete $f\nreturn $e")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(ok "channel-append-mode"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-5.txt\nset c [open $f w]\nputs -nonewline $c \"first\"\nclose $c\nset c [open $f a]\nputs -nonewline $c \"-second\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out")
|
||||
:result)
|
||||
"first-second")
|
||||
|
||||
(ok "channel-seek-end"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-6.txt\nset c [open $f w]\nputs -nonewline $c \"abcdefghij\"\nclose $c\nset c [open $f r]\nseek $c 0 end\nset pos [tell $c]\nclose $c\nfile delete $f\nreturn $pos")
|
||||
:result)
|
||||
"10")
|
||||
|
||||
(ok "channel-fconfigure-blocking"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-7.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset c [open $f r]\nfconfigure $c -blocking 0\nset b [fconfigure $c -blocking]\nclose $c\nfile delete $f\nreturn $b")
|
||||
:result)
|
||||
"0")
|
||||
|
||||
(dict
|
||||
"passed"
|
||||
tcl-idiom-pass
|
||||
|
||||
Reference in New Issue
Block a user