suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
995e53ca71
racket/mats/unix.ms
dybvig d0b405ac8b library-manager, numeric, and bytevector-compres improvements 
- added invoke-library
    syntax.ss, primdata.ss,
    8.ms, root-experr*,
    libraries.stex, release_notes.stex
- updated the date
    release_notes.stex
- libraries contained within a whole program or library are now
  marked pending before their invoke code is run so that invoke
  cycles are reported as such rather than as attempts to invoke
  while still loading.
    compile.ss, syntax.ss, primdata.ss,
    7.ms, root-experr*
- the library manager now protects against unbound references
  from separately compiled libraries or programs to identifiers
  ostensibly but not actually exported by (invisible) libraries
  that exist only locally within a whole program.  this is done by
  marking the invisibility of the library in the library-info and
  propagating it to libdesc records; the latter is checked upon
  library import, visit, and invoke as well as by verify-loadability.
  the import and visit code of each invisible no longer complains
  about invisibility since it shouldn't be reachable.
    syntax.ss, compile.ss, expand-lang.ss,
    7.ms, 8.ms, root-experr*, patch*
- documented that compile-whole-xxx's linearization of the
  library initialization code based on static dependencies might
  not work for dynamic dependencies.
    system.stex
- optimized bignum right shifts so the code (1) doesn't look at
  shifted-off bigits if the bignum is positive, since it doesn't
  need to know in that case if any bits are set; (2) doesn't look
  at shifted-off bigits if the bignum is negative if it determines
  that at least one bit is set in the bits shifted off the low-order
  partially retained bigit; (3) quits looking, if it must look, for
  one bits as soon as it finds one; (4) looks from both ends under
  the assumption that set bits, if any, are most likely to be found
  toward the high or low end of the bignum rather than just in the
  middle; and (5) doesn't copy the retained bigits and then shift;
  rather shifts as it copies.  This leads to dramatic improvements
  when the shift count is large and often significant improvements
  otherwise.
    number.c,
    5_3.ms,
    release_notes.stex
- threaded tc argument through to all calls to S_bignum and
  S_trunc_rem so they don't have to call get_thread_context()
  when it might already have been called.
    alloc.c, number.c, fasl.c, print.c, prim5.c, externs.h
- added an expand-primitive handler to partially inline integer?.
    cpnanopass.ss
- added some special cases for basic arithmetic operations (+, -, *,
  /, quotient, remainder, and the div/div0/mod/mod0 operations) to
  avoid doing unnecessary work for large bignums when the result
  will be zero (e.g,. multiplying by 0), the same as one of the
  inputs (e.g., adding 0 or multiplying by 1), or the additive
  inverse of one of the inputs (e.g., subtracting from 0, dividing
  by -1).  This can have a major beneficial affect when operating
  on large bignums in the cases handled.  also converted some uses
  of / into integer/ where going through the former would just add
  overhead without the possibility of optimization.
    5_3.ss,
    number.c, externs.h, prim5.c,
    5_3.ms, root-experr, patch*,
    release_notes.stex
- added a queue to hold pending signals for which handlers have
  been registered via register-signal-handler so up to 63 (configurable
  in the source code) unhandled signals are buffered before the
  handler has to start dropping them.
    cmacros.ss, library.ss, prims.ss, primdata.ss,
    schsig.c, externs.h, prim5.c, thread.c, gc.c,
    unix.ms,
    system.stex, release_notes.stex
- bytevector-compress now selects the level of compression based
  on the compress-level parameter.  Prior to this it always used a
  default setting for compression.  the compress-level parameter
  can now take on the new minimum in addition to low, medium, high,
  and maximum.  minimum is presently treated the same as low
  except in the case of lz4 bytevector compression, where it
  results in the use of LZ4_compress_default rather than the
  slower but more effective LZ4_compress_HC.
    cmacros,ss, back.ss,
    compress_io.c, new_io.c, externs.h,
    bytevector.ms, mats/Mf-base, root-experr*
    io.stex, objects.stex, release_notes.stex

original commit: 72d90e4c67849908da900d0b6249a1dedb5f8c7f
2020-02-21 13:48:47 -08:00

707 lines
30 KiB
Scheme
Raw Blame History

;;; 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 (format "~:[~;/pkg~]/bin/rm testfile.ss" (embedded?)))
(system (format "~:[~;/pkg~]/bin/echo hello > testfile.ss" (embedded?)))
(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, particulary 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 New Issue View Git Blame Copy Permalink