feat: 9.5.9
This commit is contained in:
tmtt
parent
cb1753732b
commit
35f43a7909
1084 changed files with 558985 additions and 0 deletions
706
mats/unix.ms
Normal file
706
mats/unix.ms
Normal file
|
|
@ -0,0 +1,706 @@
|
|||
;;; unix.ms
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(if (or (windows?) (equal? (getenv "USER") "root") (embedded?))
|
||||
(mat unix-file-io
|
||||
(error? (errorf 'open-output-file "failed for testfile.ss: file exists"))
|
||||
(error? (errorf 'open-output-file "failed for testfile.ss: file exists"))
|
||||
(error? (errorf 'open-output-file "failed for testfile.ss: permission denied"))
|
||||
(error? (errorf 'open-output-file "failed for testfile.ss: permission denied"))
|
||||
(error? (errorf 'open-output-file "failed for testfile.ss: file exists"))
|
||||
(error? (errorf 'open-output-file "failed for testfile.ss: file exists"))
|
||||
(error? (errorf 'open-output-file "failed for testfile.ss: permission denied"))
|
||||
(error? (errorf 'open-output-file "failed for testfile.ss: permission denied"))
|
||||
(error? (errorf 'open-input-file "failed for testfile.ss: permission denied"))
|
||||
(error? (errorf 'open-input-output-file "failed for testfile.ss: permission denied"))
|
||||
(error? (errorf 'with-output-to-file "failed for testfile.ss: permission denied"))
|
||||
(error? (errorf 'with-input-from-file "failed for testfile.ss: permission denied"))
|
||||
(error? (errorf 'call-with-input-file "failed for testfile.ss: permission denied"))
|
||||
)
|
||||
(mat unix-file-io
|
||||
(let ([p (open-output-file "/dev/null" 'truncate)])
|
||||
(close-output-port p)
|
||||
#t)
|
||||
(let ([p (open-output-file "testfile.ss" 'truncate)])
|
||||
(close-output-port p)
|
||||
(system "chmod -w testfile.ss")
|
||||
#t)
|
||||
(error? (open-output-file "testfile.ss"))
|
||||
(error? (open-output-file "testfile.ss" 'error))
|
||||
(error? (open-output-file "testfile.ss" 'truncate))
|
||||
(error? (open-output-file "testfile.ss" 'append))
|
||||
(let ([p (open-output-file "testfile.ss" 'replace)])
|
||||
(close-output-port p)
|
||||
#t)
|
||||
(delete-file "testfile.ss" #f)
|
||||
(eqv?
|
||||
(with-output-to-file "testfile.ss"
|
||||
(lambda () (display "hello\n"))
|
||||
'(mode #o000))
|
||||
(void))
|
||||
(error? (open-output-file "testfile.ss"))
|
||||
(error? (open-output-file "testfile.ss" 'error))
|
||||
(error? (open-output-file "testfile.ss" 'truncate))
|
||||
(error? (open-output-file "testfile.ss" 'append))
|
||||
(error? (open-input-file "testfile.ss"))
|
||||
(error? (open-input-output-file "testfile.ss"))
|
||||
(error? (with-output-to-file "testfile.ss" void '(truncate)))
|
||||
(error? (with-input-from-file "testfile.ss" void))
|
||||
(error? (call-with-input-file "testfile.ss" values))
|
||||
(delete-file "testfile.ss" #f)
|
||||
)
|
||||
)
|
||||
|
||||
(mat system
|
||||
(error? ; not a string
|
||||
(system 5))
|
||||
)
|
||||
|
||||
(unless (windows?)
|
||||
(mat system
|
||||
(eqv? (with-output-to-file "testfile.ss" void '(replace)) (void))
|
||||
(begin
|
||||
(system "rm -f testfile.ss")
|
||||
(system "echo hello > testfile.ss")
|
||||
(let ([p (open-input-file "testfile.ss")])
|
||||
(and (eq? (read p) 'hello)
|
||||
(begin (close-input-port p) #t))))
|
||||
)
|
||||
)
|
||||
|
||||
(unless (windows?)
|
||||
(mat process-port
|
||||
(let ()
|
||||
(define make-process-port
|
||||
(let ()
|
||||
(define kill
|
||||
(lambda (pid sig)
|
||||
(if (= sig 0)
|
||||
-1
|
||||
(system (format "kill -~s ~s" sig pid)))))
|
||||
(define make-handler
|
||||
(lambda (name ip op pid)
|
||||
(lambda (msg . args)
|
||||
(record-case (cons msg args)
|
||||
[block-read (p s n) (block-read ip s n)]
|
||||
[block-write (p s n) (block-write op s n)]
|
||||
[char-ready? (p) (char-ready? ip)]
|
||||
[clear-input-port (p) (clear-input-port ip)]
|
||||
[clear-output-port (p) (clear-output-port op)]
|
||||
[close-port (p)
|
||||
(close-port ip)
|
||||
(close-port op)
|
||||
(mark-port-closed! p)]
|
||||
[file-position (p . pos)
|
||||
(if (null? pos)
|
||||
(most-negative-fixnum)
|
||||
(errorf 'process-port "cannot reposition"))]
|
||||
[flush-output-port (p) (flush-output-port op)]
|
||||
[kill (p signal) (kill pid signal)]
|
||||
[peek-char (p) (peek-char ip)]
|
||||
[port-name (p) name]
|
||||
[read-char (p) (read-char ip)]
|
||||
[unread-char (c p) (unread-char c ip)]
|
||||
[write-char (c p) (write-char c op)]
|
||||
[else (errorf 'process-port "operation ~s not handled" msg)]))))
|
||||
(lambda (command)
|
||||
(let ([handler
|
||||
(apply
|
||||
make-handler
|
||||
(format "process ~s" command)
|
||||
(process command))])
|
||||
(make-input/output-port handler "" "")))))
|
||||
(define port-kill
|
||||
(lambda (p s) ((port-handler p) 'kill p s)))
|
||||
(and (let ()
|
||||
(define p (make-process-port (format "exec ~a" $cat_flush)))
|
||||
(and (not (char-ready? p))
|
||||
(begin (fprintf p "hello!~%") (eq? (read p) 'hello!))
|
||||
(char-ready? p)
|
||||
(char=? (read-char p) #\newline)
|
||||
(not (char-ready? p))
|
||||
(begin (close-port p) #t)
|
||||
; sleep 1 may not be enough on a loaded system...
|
||||
(begin (system "sleep 5") (= (port-kill p 0) -1))))
|
||||
(let ()
|
||||
(define p (make-process-port (format "exec ~a" $cat_flush)))
|
||||
(and (not (char-ready? p))
|
||||
(begin (fprintf p "hello!~%") (eq? (read p) 'hello!))
|
||||
(char-ready? p)
|
||||
(char=? (read-char p) #\newline)
|
||||
(not (char-ready? p))
|
||||
(= (port-kill p 15) 0)
|
||||
(let f () (if (char-ready? p) (eof-object? (read-char p)) (f)))
|
||||
; sleep 1 may not be enough on a loaded system...
|
||||
(begin (system "sleep 1") (eqv? (port-kill p 0) -1))))))
|
||||
)
|
||||
)
|
||||
|
||||
(if (windows?)
|
||||
(mat register-signal-handler
|
||||
(error? (errorf 'register-signal-handler
|
||||
"#<procedure list> is not a fixnum"))
|
||||
(error? (errorf 'register-signal-handler "14 is not a procedure"))
|
||||
(error? (errorf 'register-signal-handler
|
||||
"#<procedure list> is not a fixnum"))
|
||||
)
|
||||
(mat register-signal-handler
|
||||
(error? (register-signal-handler list 14))
|
||||
(error? (register-signal-handler 14 14))
|
||||
(error? (register-signal-handler list list))
|
||||
(let ((x '()))
|
||||
(register-signal-handler 14 (lambda (sig) (set! x (cons sig x))))
|
||||
; guard the call to system, since openbsd gets an EINTR error,
|
||||
; probably in system's call to waitpid, causing s_system to
|
||||
; raise an exception
|
||||
(guard (c [#t (display-condition c) (printf "\nexception ignored\n")])
|
||||
(system "exec kill -14 $PPID")
|
||||
(system "exec kill -14 $PPID")
|
||||
(system "exec kill -14 $PPID")
|
||||
(system "exec kill -14 $PPID"))
|
||||
(let f ((n 1000000))
|
||||
(or (equal? x '(14 14 14 14))
|
||||
(and (not (= n 0))
|
||||
(f (- n 1))))))
|
||||
)
|
||||
)
|
||||
|
||||
(if (or (windows?) (equal? (getenv "USER") "root") (embedded?))
|
||||
(mat file-operations
|
||||
(error? (errorf 'delete-directory "failed for ~a: ~a" "testlink1" "not a directory"))
|
||||
(error? (errorf 'delete-directory "failed for ~a: ~a" "testlink2" "not a directory"))
|
||||
(error? (errorf 'delete-directory "failed for ~a: ~a" "testdir/testfile.ss" "not a directory"))
|
||||
(error? (errorf 'delete-file "failed for ~a: ~a" "testdir/w" "permission denied"))
|
||||
(error? (errorf 'get-mode "failed for ~s: ~(~a~)" "testlink" "no such file or directory"))
|
||||
(error? (errorf 'file-access-time "failed for ~s: ~(~a~)" "testlink" "no such file or directory"))
|
||||
(error? (errorf 'file-change-time "failed for ~s: ~(~a~)" "testlink" "no such file or directory"))
|
||||
(error? (errorf 'file-modification-time "failed for ~s: ~(~a~)" "testlink" "no such file or directory"))
|
||||
(error? (errorf 'get-mode "failed for ~s: ~(~a~)" "testlink" "no such file or directory"))
|
||||
(error? (errorf 'file-access-time "failed for ~s: ~(~a~)" "testlink" "no such file or directory"))
|
||||
(error? (errorf 'file-change-time "failed for ~s: ~(~a~)" "testlink" "no such file or directory"))
|
||||
(error? (errorf 'file-modification-time "failed for ~s: ~(~a~)" "testlink" "no such file or directory"))
|
||||
)
|
||||
(mat file-operations
|
||||
(boolean? (delete-file "testlink1" #f))
|
||||
(boolean? (delete-file "testlink2" #f))
|
||||
(not (file-exists? "testdir"))
|
||||
(begin
|
||||
(system "ln -s testdir testlink1")
|
||||
(and
|
||||
(not (file-exists? "testlink1"))
|
||||
(not (file-exists? "testlink1" #t))
|
||||
(file-exists? "testlink1" #f))
|
||||
(and
|
||||
(not (file-regular? "testlink1"))
|
||||
(not (file-regular? "testlink1" #t))
|
||||
(not (file-regular? "testlink1" #f)))
|
||||
(and
|
||||
(not (file-directory? "testlink1"))
|
||||
(not (file-directory? "testlink1" #t))
|
||||
(not (file-directory? "testlink1" #f)))
|
||||
(file-symbolic-link? "testlink1"))
|
||||
(begin
|
||||
(system "ln -s testdir/testfile.ss testlink2")
|
||||
(and
|
||||
(not (file-exists? "testlink2"))
|
||||
(not (file-exists? "testlink2" #t))
|
||||
(file-exists? "testlink2" #f))
|
||||
(and
|
||||
(not (file-regular? "testlink2"))
|
||||
(not (file-regular? "testlink2" #t))
|
||||
(not (file-regular? "testlink2" #f)))
|
||||
(and
|
||||
(not (file-directory? "testlink2"))
|
||||
(not (file-directory? "testlink2" #t))
|
||||
(not (file-directory? "testlink2" #f)))
|
||||
(file-symbolic-link? "testlink2"))
|
||||
(begin
|
||||
(mkdir "testdir")
|
||||
(and
|
||||
(file-exists? "testlink1")
|
||||
(file-exists? "testlink1" #t)
|
||||
(file-exists? "testlink1" #f))
|
||||
(and
|
||||
(not (file-regular? "testlink1"))
|
||||
(not (file-regular? "testlink1" #t))
|
||||
(not (file-regular? "testlink1" #f)))
|
||||
(and
|
||||
(file-directory? "testlink1")
|
||||
(file-directory? "testlink1" #t)
|
||||
(not (file-directory? "testlink1" #f)))
|
||||
(file-symbolic-link? "testlink1"))
|
||||
(begin
|
||||
(and
|
||||
(not (file-exists? "testlink2"))
|
||||
(not (file-exists? "testlink2" #t))
|
||||
(file-exists? "testlink2" #f))
|
||||
(and
|
||||
(not (file-regular? "testlink2"))
|
||||
(not (file-regular? "testlink2" #t))
|
||||
(not (file-regular? "testlink2" #f)))
|
||||
(and
|
||||
(not (file-directory? "testlink2"))
|
||||
(not (file-directory? "testlink2" #t))
|
||||
(not (file-directory? "testlink2" #f)))
|
||||
(file-symbolic-link? "testlink2"))
|
||||
(begin
|
||||
(with-output-to-file "testdir/testfile.ss" values 'replace)
|
||||
(and
|
||||
(file-exists? "testlink2")
|
||||
(file-exists? "testlink2" #t)
|
||||
(file-exists? "testlink2" #f))
|
||||
(and
|
||||
(file-regular? "testlink2")
|
||||
(file-regular? "testlink2" #t)
|
||||
(not (file-regular? "testlink2" #f)))
|
||||
(and
|
||||
(not (file-directory? "testlink2"))
|
||||
(not (file-directory? "testlink2" #t))
|
||||
(not (file-directory? "testlink2" #f)))
|
||||
(file-symbolic-link? "testlink2"))
|
||||
(delete-file "testlink1" #f)
|
||||
(delete-file "testlink2" #f)
|
||||
(begin
|
||||
(system "ln -s testdir testlink1")
|
||||
(and
|
||||
(file-exists? "testlink1")
|
||||
(file-exists? "testlink1" #t)
|
||||
(file-exists? "testlink1" #f))
|
||||
(and
|
||||
(not (file-regular? "testlink1"))
|
||||
(not (file-regular? "testlink1" #t))
|
||||
(not (file-regular? "testlink1" #f)))
|
||||
(and
|
||||
(file-directory? "testlink1")
|
||||
(file-directory? "testlink1" #t)
|
||||
(not (file-directory? "testlink1" #f)))
|
||||
(file-symbolic-link? "testlink1"))
|
||||
(begin
|
||||
(system "ln -s testdir/testfile.ss testlink2")
|
||||
(and
|
||||
(file-exists? "testlink2")
|
||||
(file-exists? "testlink2" #t)
|
||||
(file-exists? "testlink2" #f))
|
||||
(and
|
||||
(file-regular? "testlink2")
|
||||
(file-regular? "testlink2" #t)
|
||||
(not (file-regular? "testlink2" #f)))
|
||||
(and
|
||||
(not (file-directory? "testlink2"))
|
||||
(not (file-directory? "testlink2" #t))
|
||||
(not (file-directory? "testlink2" #f)))
|
||||
(file-symbolic-link? "testlink2"))
|
||||
(error? (delete-directory "testlink1" #t))
|
||||
(error? (delete-directory "testlink2" #t))
|
||||
(delete-file "testlink1" #f)
|
||||
(delete-file "testlink2" #f)
|
||||
(guard (c [(and (i/o-filename-error? c)
|
||||
(equal? (i/o-error-filename c) "testdir"))])
|
||||
(delete-directory "testdir" #t))
|
||||
(error? (delete-directory "testdir/testfile.ss" #t))
|
||||
(delete-file "testdir/testfile.ss" #f)
|
||||
(guard (c [(and (i/o-filename-error? c)
|
||||
(equal? (i/o-error-filename c) "testdir"))])
|
||||
(delete-file "testdir" #t))
|
||||
(eqv? (delete-directory "testdir" #t) (void))
|
||||
(begin
|
||||
(mkdir "testdir" #o700)
|
||||
#t)
|
||||
(begin
|
||||
(with-output-to-file "testdir/r" values)
|
||||
(with-output-to-file "testdir/w" values)
|
||||
(with-output-to-file "testdir/x" values)
|
||||
(with-output-to-file "testdir/rx" values)
|
||||
(with-output-to-file "testdir/rw" values)
|
||||
(chmod "testdir/r" #o400)
|
||||
(chmod "testdir/w" #o200)
|
||||
(chmod "testdir/x" #o100)
|
||||
(chmod "testdir/rx" #o500)
|
||||
(chmod "testdir/rw" #o600)
|
||||
#t)
|
||||
(eqv? (chmod "testdir" #o500) (void))
|
||||
(error? (delete-file "testdir/w" #t))
|
||||
(eqv? (chmod "testdir" #o700) (void))
|
||||
(guard (c [(and (i/o-filename-error? c)
|
||||
(equal? (i/o-error-filename c) "testdir"))])
|
||||
(delete-directory "testdir" #t))
|
||||
(eqv? (delete-file "testdir/w" #t) (void))
|
||||
(eqv? (delete-file "testdir/rw" #t) (void))
|
||||
(delete-file "testdir/r" #f)
|
||||
(delete-file "testdir/x" #f)
|
||||
(delete-file "testdir/rx")
|
||||
(delete-directory "testdir" #f)
|
||||
(begin
|
||||
(system "echo one > testfile.ss")
|
||||
(system "ln -s testfile.ss testlink")
|
||||
#t)
|
||||
(time=? (file-access-time "testlink") (file-access-time "testfile.ss"))
|
||||
(time=? (file-change-time "testlink") (file-change-time "testfile.ss"))
|
||||
(time=? (file-modification-time "testlink") (file-modification-time "testfile.ss"))
|
||||
; no guarantee what times are returned for symbolic links.
|
||||
; just make sure they return time objects
|
||||
(andmap time?
|
||||
(map (lambda (p) (p "testlink" #f))
|
||||
(list file-access-time file-change-time file-modification-time)))
|
||||
(= (get-mode "testlink") (get-mode "testfile.ss"))
|
||||
(begin
|
||||
(define $taccess (file-access-time "testfile.ss"))
|
||||
(define $tmodification (file-modification-time "testfile.ss"))
|
||||
(define $tchange (file-change-time "testfile.ss"))
|
||||
#t)
|
||||
(eq? (sleep (make-time 'time-duration 0 2)) (void))
|
||||
(symbol? (with-input-from-file "testfile.ss" read))
|
||||
; following should be time<?, but access times are not updated on some
|
||||
; file systems, particularly nfs file systems. but we wouldn't expect
|
||||
; time to run backwards (except for one hour for DST)
|
||||
(time<=? $taccess (file-access-time "testfile.ss"))
|
||||
(begin
|
||||
(system "echo two > testfile.ss")
|
||||
#t)
|
||||
; for whatever reason, there seems to be no guarantee about this either ...
|
||||
(time<=? $tmodification (file-modification-time "testfile.ss"))
|
||||
(or (begin
|
||||
(chmod "testfile.ss" #o770)
|
||||
(not (= (get-mode "testlink" #f) (get-mode "testfile.ss"))))
|
||||
(begin
|
||||
(chmod "testfile.ss" #o777)
|
||||
(not (= (get-mode "testlink" #f) (get-mode "testfile.ss")))))
|
||||
; ... or this
|
||||
(time>=? (file-change-time "testfile.ss") $tchange)
|
||||
(delete-file "testfile.ss" #f)
|
||||
(andmap time?
|
||||
(map (lambda (p) (p "testlink" #f))
|
||||
(list file-access-time file-change-time file-modification-time)))
|
||||
(error? (get-mode "testlink"))
|
||||
(error? (file-access-time "testlink"))
|
||||
(error? (file-change-time "testlink"))
|
||||
(error? (file-modification-time "testlink"))
|
||||
(error? (get-mode "testlink" #t))
|
||||
(error? (file-access-time "testlink" #t))
|
||||
(error? (file-change-time "testlink" #t))
|
||||
(error? (file-modification-time "testlink" #t))
|
||||
(delete-file "testlink" #f)
|
||||
)
|
||||
)
|
||||
|
||||
(if (windows?)
|
||||
(mat nonblocking
|
||||
; verify no windows nonblocking support for binary file ports
|
||||
(let-values ([(to-stdin from-stdout from-stderr pid)
|
||||
(open-process-ports $cat_flush)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(and (not (port-has-port-nonblocking?? to-stdin))
|
||||
(not (port-has-set-port-nonblocking!? to-stdin))
|
||||
(not (port-has-port-nonblocking?? from-stdout))
|
||||
(not (port-has-set-port-nonblocking!? from-stdout))
|
||||
(not (port-has-port-nonblocking?? from-stderr))
|
||||
(not (port-has-set-port-nonblocking!? from-stderr))))
|
||||
(lambda ()
|
||||
(close-port to-stdin)
|
||||
(close-port from-stdout)
|
||||
(close-port from-stderr))))
|
||||
; verify no windows nonblocking support for textual file ports
|
||||
(let-values ([(to-stdin from-stdout from-stderr pid)
|
||||
(open-process-ports $cat_flush (buffer-mode block) (native-transcoder))])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(and (not (port-has-port-nonblocking?? to-stdin))
|
||||
(not (port-has-set-port-nonblocking!? to-stdin))
|
||||
(not (port-has-port-nonblocking?? from-stdout))
|
||||
(not (port-has-set-port-nonblocking!? from-stdout))
|
||||
(not (port-has-port-nonblocking?? from-stderr))
|
||||
(not (port-has-set-port-nonblocking!? from-stderr))))
|
||||
(lambda ()
|
||||
(close-port to-stdin)
|
||||
(close-port from-stdout)
|
||||
(close-port from-stderr))))
|
||||
)
|
||||
(mat nonblocking ; see also io.ms (mat open-process-ports ...)
|
||||
; test get-bytevector-some on nonblocking binary input port
|
||||
(let-values ([(to-stdin from-stdout from-stderr pid)
|
||||
(open-process-ports $cat_flush)])
|
||||
(define put-string
|
||||
(lambda (bp s)
|
||||
(put-bytevector bp (string->utf8 s))))
|
||||
(define get-string-some
|
||||
(lambda (bp)
|
||||
(let ([x (get-bytevector-some bp)])
|
||||
(if (eof-object? x) x (utf8->string x)))))
|
||||
(define get-string-n
|
||||
(lambda (bp n)
|
||||
(let ([x (get-bytevector-n bp n)])
|
||||
(if (eof-object? x) x (utf8->string x)))))
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(put-string to-stdin "life in the fast lane\n")
|
||||
(flush-output-port to-stdin)
|
||||
(let f ()
|
||||
(when (input-port-ready? from-stderr)
|
||||
(errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
|
||||
(if (input-port-ready? from-stdout)
|
||||
(let ([s (get-string-n from-stdout 10)])
|
||||
(unless (equal? s "life in th")
|
||||
(errorf #f "unexpected from-stdout string ~s" s)))
|
||||
(begin
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f))))
|
||||
(set-port-nonblocking! from-stdout #t)
|
||||
(let f ([all ""])
|
||||
(let ([s (get-string-some from-stdout)])
|
||||
(when (eof-object? s) (errorf #f "unexpected from-stdout eof"))
|
||||
(if (equal? s "")
|
||||
(unless (equal? all "e fast lane\n")
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f all))
|
||||
(f (string-append all s)))))
|
||||
(and
|
||||
(equal? (get-string-some from-stdout) "")
|
||||
(not (input-port-ready? from-stdout))
|
||||
(equal? (get-string-some from-stdout) "")
|
||||
(begin
|
||||
(close-port to-stdin)
|
||||
(let f ()
|
||||
(unless (and (port-eof? from-stdout) (port-eof? from-stderr))
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f)))
|
||||
#t)))
|
||||
(lambda ()
|
||||
(close-port to-stdin)
|
||||
(close-port from-stdout)
|
||||
(close-port from-stderr))))
|
||||
; test get-string-some on nonblocking textual input port
|
||||
(let-values ([(to-stdin from-stdout from-stderr pid)
|
||||
(open-process-ports $cat_flush (buffer-mode block) (native-transcoder))])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(put-string to-stdin "life in the fast lane\n")
|
||||
(flush-output-port to-stdin)
|
||||
(let f ()
|
||||
(when (input-port-ready? from-stderr)
|
||||
(errorf #f "input ready on from-stderr ~s" (get-string-some from-stderr)))
|
||||
(if (input-port-ready? from-stdout)
|
||||
(let ([s (get-string-n from-stdout 10)])
|
||||
(unless (equal? s "life in th")
|
||||
(errorf #f "unexpected from-stdout string ~s" s)))
|
||||
(begin
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f))))
|
||||
(set-port-nonblocking! from-stdout #t)
|
||||
(let f ([all ""])
|
||||
(let ([s (get-string-some from-stdout)])
|
||||
(when (eof-object? s) (errorf #f "unexpected from-stdout eof"))
|
||||
(if (equal? s "")
|
||||
(unless (equal? all "e fast lane\n")
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f all))
|
||||
(f (string-append all s)))))
|
||||
(and
|
||||
(equal? (get-string-some from-stdout) "")
|
||||
(not (input-port-ready? from-stdout))
|
||||
(equal? (get-string-some from-stdout) "")
|
||||
(begin
|
||||
(close-port to-stdin)
|
||||
(let f ()
|
||||
(unless (and (port-eof? from-stdout) (port-eof? from-stderr))
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f)))
|
||||
#t)))
|
||||
(lambda ()
|
||||
(close-port to-stdin)
|
||||
(close-port from-stdout)
|
||||
(close-port from-stderr))))
|
||||
; test get-bytevector-some! on nonblocking binary input port
|
||||
(let-values ([(to-stdin from-stdout from-stderr pid)
|
||||
(open-process-ports $cat_flush)])
|
||||
(define get-bytevector-some
|
||||
(lambda (bp)
|
||||
(let ([buf (make-bytevector 5)])
|
||||
(let ([n (get-bytevector-some! bp buf 0 (bytevector-length buf))])
|
||||
(if (eof-object? n)
|
||||
n
|
||||
(bytevector-truncate! buf n))))))
|
||||
(define put-string
|
||||
(lambda (bp s)
|
||||
(put-bytevector bp (string->utf8 s))))
|
||||
(define get-string-some
|
||||
(lambda (bp)
|
||||
(let ([x (get-bytevector-some bp)])
|
||||
(if (eof-object? x) x (utf8->string x)))))
|
||||
(define get-string-n
|
||||
(lambda (bp n)
|
||||
(let ([x (get-bytevector-n bp n)])
|
||||
(if (eof-object? x) x (utf8->string x)))))
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(set-port-nonblocking! to-stdin #t) ; not testing whether this does anything
|
||||
(set-port-nonblocking! from-stdout #t)
|
||||
(set-port-nonblocking! from-stderr #t)
|
||||
(put-string to-stdin "that don't impress me much\n")
|
||||
(flush-output-port to-stdin)
|
||||
(let f ([all ""])
|
||||
(unless (equal? all "that don't impress me much\n")
|
||||
(let ([s (get-string-some from-stderr)])
|
||||
(when (eof-object? s) (errorf #f "unexpected from-stderr eof"))
|
||||
(unless (equal? s "") (errorf #f "unexpected from-stderr input ~s" s)))
|
||||
(let ([s (get-string-some from-stdout)])
|
||||
(when (eof-object? s) (errorf #f "unexpected from-stdout eof"))
|
||||
(if (equal? s "")
|
||||
(begin
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f all))
|
||||
(f (string-append all s))))))
|
||||
(and
|
||||
(equal? (get-string-some from-stdout) "")
|
||||
(not (input-port-ready? from-stdout))
|
||||
(equal? (get-string-some from-stdout) "")
|
||||
(begin
|
||||
(close-port to-stdin)
|
||||
(let f ()
|
||||
(unless (and (port-eof? from-stdout) (port-eof? from-stderr))
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f)))
|
||||
#t)))
|
||||
(lambda ()
|
||||
(close-port to-stdin)
|
||||
(close-port from-stdout)
|
||||
(close-port from-stderr))))
|
||||
; test get-string-some! on nonblocking textual input port
|
||||
(let-values ([(to-stdin from-stdout from-stderr pid)
|
||||
(open-process-ports $cat_flush (buffer-mode block) (native-transcoder))])
|
||||
(define get-string-some
|
||||
(lambda (tp)
|
||||
(let ([buf (make-string 5)])
|
||||
(let ([n (get-string-some! tp buf 0 (string-length buf))])
|
||||
(if (eof-object? n)
|
||||
n
|
||||
(substring buf 0 n))))))
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(set-port-nonblocking! to-stdin #t) ; not testing whether this does anything
|
||||
(set-port-nonblocking! from-stdout #t)
|
||||
(set-port-nonblocking! from-stderr #t)
|
||||
(put-string to-stdin "that don't impress me much\n")
|
||||
(flush-output-port to-stdin)
|
||||
(let f ([all ""])
|
||||
(unless (equal? all "that don't impress me much\n")
|
||||
(let ([s (get-string-some from-stderr)])
|
||||
(when (eof-object? s) (errorf #f "unexpected from-stderr eof"))
|
||||
(unless (equal? s "") (errorf #f "unexpected from-stderr input ~s" s)))
|
||||
(let ([s (get-string-some from-stdout)])
|
||||
(when (eof-object? s) (errorf #f "unexpected from-stdout eof"))
|
||||
(if (equal? s "")
|
||||
(begin
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f all))
|
||||
(f (string-append all s))))))
|
||||
(and
|
||||
(equal? (get-string-some from-stdout) "")
|
||||
(not (input-port-ready? from-stdout))
|
||||
(equal? (get-string-some from-stdout) "")
|
||||
(begin
|
||||
(close-port to-stdin)
|
||||
(let f ()
|
||||
(unless (and (port-eof? from-stdout) (port-eof? from-stderr))
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f)))
|
||||
#t)))
|
||||
(lambda ()
|
||||
(close-port to-stdin)
|
||||
(close-port from-stdout)
|
||||
(close-port from-stderr))))
|
||||
; test put-bytevector-some on nonblocking binary output port,
|
||||
; counting on O/S to limit amount we can write to a pipe that
|
||||
; no one has yet read from
|
||||
(let-values ([(to-stdin from-stdout from-stderr pid)
|
||||
(open-process-ports $cat_flush (buffer-mode none))])
|
||||
(define put-string-some
|
||||
(lambda (bp s)
|
||||
(put-bytevector-some bp (string->utf8 s) 0 (string-length s))))
|
||||
(define get-string-some
|
||||
(lambda (bp)
|
||||
(let ([x (get-bytevector-some bp)])
|
||||
(if (eof-object? x) x (utf8->string x)))))
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(define s "my future lies beyond the yellow brick road")
|
||||
(set-port-nonblocking! to-stdin #t)
|
||||
(set-port-nonblocking! from-stdout #t)
|
||||
(set-port-nonblocking! from-stderr #t)
|
||||
(let ([len (string-length s)])
|
||||
(let f ([n 0])
|
||||
(let ([i (put-string-some to-stdin s)])
|
||||
(if (= i len)
|
||||
(f (+ n 1))
|
||||
(let f ()
|
||||
(if (string=? (get-string-some from-stdout) "")
|
||||
(or (= (put-string-some to-stdin "\n") 1)
|
||||
(begin
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f)))
|
||||
(f))))))))
|
||||
(lambda ()
|
||||
(close-port to-stdin)
|
||||
(close-port from-stdout)
|
||||
(close-port from-stderr))))
|
||||
; test put-string-some on nonblocking textual output port,
|
||||
; counting on O/S to limit amount we can write to a pipe that
|
||||
; no one has yet read from
|
||||
(let-values ([(to-stdin from-stdout from-stderr pid)
|
||||
(open-process-ports $cat_flush (buffer-mode none) (native-transcoder))])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(define s "my future lies beyond the yellow brick road")
|
||||
(set-port-nonblocking! to-stdin #t)
|
||||
(set-port-nonblocking! from-stdout #t)
|
||||
(set-port-nonblocking! from-stderr #t)
|
||||
(let ([len (string-length s)])
|
||||
(let f ([n 0])
|
||||
(let ([i (put-string-some to-stdin s)])
|
||||
(if (= i len)
|
||||
(f (+ n 1))
|
||||
(let f ()
|
||||
(if (string=? (get-string-some from-stdout) "")
|
||||
(or (= (put-string-some to-stdin "\n") 1)
|
||||
(begin
|
||||
(display ".")
|
||||
(flush-output-port)
|
||||
(f)))
|
||||
(f))))))))
|
||||
(lambda ()
|
||||
(close-port to-stdin)
|
||||
(close-port from-stdout)
|
||||
(close-port from-stderr))))
|
||||
)
|
||||
)
|
||||
Reference in a new issue