1398 lines
46 KiB
Scheme
1398 lines
46 KiB
Scheme
|
|
(load-relative "loadtest.ss")
|
|
|
|
(define testing.ss (build-path (current-load-relative-directory) "testing.ss"))
|
|
|
|
(SECTION 6 10 1)
|
|
(test #t input-port? (current-input-port))
|
|
(test #t output-port? (current-output-port))
|
|
(test #t output-port? (current-error-port))
|
|
(test (void) current-input-port (current-input-port))
|
|
(test (void) current-output-port (current-output-port))
|
|
(test (void) current-error-port (current-error-port))
|
|
(test #t call-with-input-file testing.ss input-port?)
|
|
(define this-file (open-input-file testing.ss))
|
|
(test #t input-port? this-file)
|
|
(close-input-port this-file)
|
|
(define this-file (open-input-file testing.ss 'binary))
|
|
(test #t input-port? this-file)
|
|
(close-input-port this-file)
|
|
(define this-file (open-input-file testing.ss 'text))
|
|
(test #t input-port? this-file)
|
|
(arity-test input-port? 1 1)
|
|
(arity-test output-port? 1 1)
|
|
(arity-test current-input-port 0 1)
|
|
(arity-test current-output-port 0 1)
|
|
(arity-test current-error-port 0 1)
|
|
(err/rt-test (current-input-port 8))
|
|
(err/rt-test (current-output-port 8))
|
|
(err/rt-test (current-error-port 8))
|
|
(err/rt-test (current-input-port (current-output-port)))
|
|
(err/rt-test (current-output-port (current-input-port)))
|
|
(err/rt-test (current-error-port (current-input-port)))
|
|
(SECTION 6 10 2)
|
|
(test #\; peek-char this-file)
|
|
(arity-test peek-char 0 2)
|
|
(arity-test peek-char-or-special 0 2)
|
|
(test #\; read-char this-file)
|
|
(arity-test read-char 0 1)
|
|
(arity-test read-char-or-special 0 1)
|
|
(test '(define cur-section '()) read this-file)
|
|
(arity-test read 0 1)
|
|
(test #\( peek-char this-file)
|
|
(test '(define errs '()) read this-file)
|
|
(close-input-port this-file)
|
|
(close-input-port this-file)
|
|
(arity-test close-input-port 1 1)
|
|
(arity-test close-output-port 1 1)
|
|
(err/rt-test (peek-char 5))
|
|
(err/rt-test (peek-char (current-output-port)))
|
|
(err/rt-test (read-char 5))
|
|
(err/rt-test (read-char (current-output-port)))
|
|
(err/rt-test (read 5))
|
|
(err/rt-test (read (current-output-port)))
|
|
(err/rt-test (close-input-port 5))
|
|
(err/rt-test (close-output-port 5))
|
|
(err/rt-test (close-input-port (current-output-port)))
|
|
(err/rt-test (close-output-port (current-input-port)))
|
|
(define (check-test-file name)
|
|
(define test-file (open-input-file name))
|
|
(test #t 'input-port?
|
|
(call-with-input-file
|
|
name
|
|
(lambda (test-file)
|
|
(test load-test-obj read test-file)
|
|
(test #t eof-object? (peek-char test-file))
|
|
(test #t eof-object? (read-char test-file))
|
|
(input-port? test-file))))
|
|
(test #\; read-char test-file)
|
|
(test display-test-obj read test-file)
|
|
(test load-test-obj read test-file)
|
|
(close-input-port test-file))
|
|
(SECTION 6 10 3)
|
|
(define write-test-obj
|
|
'(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
|
|
(define display-test-obj
|
|
'(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
|
|
(define load-test-obj
|
|
(list 'define 'foo (list 'quote write-test-obj)))
|
|
(let ([f (lambda (test-file)
|
|
(write-char #\; test-file)
|
|
(display write-test-obj test-file)
|
|
(newline test-file)
|
|
(write load-test-obj test-file)
|
|
(output-port? test-file))])
|
|
(test #t call-with-output-file
|
|
"tmp1" f 'truncate))
|
|
(check-test-file "tmp1")
|
|
|
|
(test (string #\null #\null #\" #\\ #\u #\0 #\0 #\0 #\0 #\")
|
|
'write-null
|
|
(let ([p (open-output-string)])
|
|
(write-char #\null p)
|
|
(display (string #\null) p)
|
|
(write (string #\null) p)
|
|
(let ([s (get-output-string p)])
|
|
s)))
|
|
|
|
;; Test escapes (input):
|
|
(test (apply
|
|
string
|
|
(map
|
|
integer->char
|
|
'(7 8 9 10 12 13 27 11 92 34 65 32 5 65 15 80 15 80 221 68 255 55 1 49)))
|
|
values "\a\b\t\n\f\r\e\v\\\"\101\40\5A\xFP\xfP\xdDD\3777\0011")
|
|
(err/rt-test (read (open-input-string "\"\\z\"")) exn:fail:read?)
|
|
(err/rt-test (read (open-input-string "\"\\xX\"")) exn:fail:read?)
|
|
(err/rt-test (read (open-input-string "\"\\x\"")) exn:fail:read?)
|
|
(err/rt-test (read (open-input-string "\"\\x")) exn:fail:read:eof?)
|
|
(err/rt-test (read (open-input-string "\"\\400\"")) exn:fail:read?)
|
|
(err/rt-test (read (open-input-string "\"\\8\"")) exn:fail:read?)
|
|
|
|
;; Test escape printing:
|
|
(parameterize ([current-locale #f])
|
|
(test "\"\\a\\b\\t\\n\\f\\r\\e\\v\\\\\\\"A \\u0005A\\u000FP\\u000FP\u00DDD\u00FF7\\u00011\\U00012345\""
|
|
'output-escapes
|
|
(let ([p (open-output-string)])
|
|
(write "\a\b\t\n\f\r\e\v\\\"\101\40\5A\xFP\xfP\xdDD\3777\0011\U12345" p)
|
|
(get-output-string p))))
|
|
|
|
(parameterize ([current-locale #f])
|
|
(test "#\"\\a\\b\\t\\n\\f\\r\\e\\v\\\\\\\"A \\5A\\17P\\17P\\335D\\3777\\0011\""
|
|
'output-escapes
|
|
(let ([p (open-output-string)])
|
|
(write #"\a\b\t\n\f\r\e\v\\\"\101\40\5A\xFP\xfP\xdDD\3777\0011" p)
|
|
(get-output-string p))))
|
|
|
|
;; Test return, linefeed, and return--linefeed escapes:
|
|
(test "12" values "1\
|
|
2")
|
|
(test "123" read (open-input-string (string #\" #\1 #\\ #\newline #\2 #\\ #\return #\3 #\")))
|
|
(test "123" read (open-input-string (string #\" #\1 #\\ #\return #\2 #\\ #\newline #\3 #\")))
|
|
(test "12\r3" read (open-input-string (string #\" #\1 #\\ #\return #\newline #\2 #\\ #\newline #\return #\3 #\")))
|
|
(test "1\r23" read (open-input-string (string #\" #\1 #\\ #\newline #\return #\2 #\\ #\return #\newline #\3 #\")))
|
|
|
|
; Test string ports with file-position:
|
|
(let ([s (open-output-string)])
|
|
(test (string) get-output-string s)
|
|
(test 0 file-position s)
|
|
(display "a" s)
|
|
(test (string #\a) get-output-string s)
|
|
(test 1 file-position s)
|
|
(test (void) file-position s 10)
|
|
(test 10 file-position s)
|
|
(test (string #\a #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul) get-output-string s)
|
|
(display "z" s)
|
|
(test (string #\a #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\z) get-output-string s)
|
|
(test 11 file-position s)
|
|
(test (void) file-position s 3)
|
|
(display "mmm" s)
|
|
(test (string #\a #\nul #\nul #\m #\m #\m #\nul #\nul #\nul #\nul #\z) get-output-string s)
|
|
(test 6 file-position s)
|
|
(display "banana" s)
|
|
(test (string #\a #\nul #\nul #\m #\m #\m #\b #\a #\n #\a #\n #\a) get-output-string s)
|
|
(test 12 file-position s))
|
|
(let ([s (open-input-string "hello")])
|
|
(test 0 file-position s)
|
|
(test #\h read-char s)
|
|
(test 1 file-position s)
|
|
(test #\e read-char s)
|
|
(test (void) file-position s 0)
|
|
(test 0 file-position s)
|
|
(test #\h read-char s)
|
|
(test (void) file-position s 4)
|
|
(test 4 file-position s)
|
|
(test #\o read-char s)
|
|
(test 5 file-position s)
|
|
(test eof read-char s)
|
|
(test 5 file-position s)
|
|
(test (void) file-position s 502)
|
|
(test eof read-char s)
|
|
(test eof read-char s)
|
|
(test 502 file-position s)
|
|
(test (void) file-position s 2)
|
|
(test #\l read-char s)
|
|
(test 3 file-position s))
|
|
|
|
(define s (open-output-string))
|
|
(err/rt-test (file-position 's 1))
|
|
(err/rt-test (file-position s 'one))
|
|
(err/rt-test (file-position s -1))
|
|
(err/rt-test (file-position s (expt 2 100)) exn:application:mismatch?)
|
|
(err/rt-test (file-position (make-input-port 'name void #f void) 100) exn:application:mismatch?)
|
|
(err/rt-test (file-position (make-output-port 'name always-evt void void) 100) exn:application:mismatch?)
|
|
(arity-test file-position 1 2)
|
|
|
|
(define (test-read-line r1 r2 s1 s2 flags sep)
|
|
(let ([p (open-input-string (string-append s1
|
|
(apply string sep)
|
|
s2))])
|
|
(test r1 apply read-line p flags)
|
|
(test r2 apply read-line p flags)))
|
|
(define (add-return s t) (string-append s (string #\return) t))
|
|
(define (add-linefeed s t) (string-append s (string #\linefeed) t))
|
|
|
|
(test-read-line "ab" "cd" "ab" "cd" null '(#\linefeed))
|
|
(test-read-line (add-return "ab" "cd") eof "ab" "cd" null '(#\return))
|
|
(test-read-line (add-return "ab" "") "cd" "ab" "cd" null '(#\return #\linefeed))
|
|
(test-read-line "ab" "cd" "ab" "cd" '(return) '(#\return))
|
|
(test-read-line (add-linefeed "ab" "cd") eof "ab" "cd" '(return) '(#\linefeed))
|
|
(test-read-line "ab" (add-linefeed "" "cd") "ab" "cd" '(return) '(#\return #\linefeed))
|
|
(test-read-line (add-return "ab" "cd") eof "ab" "cd" '(return-linefeed) '(#\return))
|
|
(test-read-line (add-linefeed "ab" "cd") eof "ab" "cd" '(return-linefeed) '(#\linefeed))
|
|
(test-read-line "ab" "cd" "ab" "cd" '(return-linefeed) '(#\return #\linefeed))
|
|
(test-read-line (add-return "ab" "") "cd" "ab" "cd" '(return-linefeed) '(#\return #\return #\linefeed))
|
|
(test-read-line "ab" (add-linefeed "" "cd") "ab" "cd" '(return-linefeed) '(#\return #\linefeed #\linefeed))
|
|
(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\return))
|
|
(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\linefeed))
|
|
(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\return #\linefeed))
|
|
(test-read-line "ab" "" "ab" "cd" '(any) '(#\linefeed #\return))
|
|
(test-read-line "ab" "cd" "ab" "cd" '(any-one) '(#\return))
|
|
(test-read-line "ab" "cd" "ab" "cd" '(any-one) '(#\linefeed))
|
|
(test-read-line "ab" "" "ab" "cd" '(any-one) '(#\return #\linefeed))
|
|
(test-read-line "ab" "" "ab" "cd" '(any-one) '(#\linefeed #\return))
|
|
|
|
(arity-test read-line 0 2)
|
|
(err/rt-test (read-line 8))
|
|
(err/rt-test (read-line 'any))
|
|
(err/rt-test (read-line (current-input-port) 8))
|
|
(err/rt-test (read-line (current-input-port) 'anyx))
|
|
|
|
(arity-test open-input-file 1 2)
|
|
(err/rt-test (open-input-file 8))
|
|
(err/rt-test (open-input-file "x" 8))
|
|
(err/rt-test (open-input-file "x" 'something-else))
|
|
(err/rt-test (open-input-file "badfile") exn:fail:filesystem?)
|
|
|
|
(arity-test open-output-file 1 3)
|
|
(err/rt-test (open-output-file 8))
|
|
(err/rt-test (open-output-file "x" 8))
|
|
(err/rt-test (open-output-file "x" 'something-else))
|
|
(let ([conflict? exn:application:mismatch?]
|
|
[modes '(binary text)]
|
|
[replacement '(error replace truncate append truncate/replace update)])
|
|
(for-each
|
|
(lambda (ones)
|
|
(for-each
|
|
(lambda (one)
|
|
(err/rt-test (open-output-file "x" one 'bad))
|
|
(err/rt-test (open-output-file "x" one 8))
|
|
(err/rt-test (open-output-file "x" 'bad one))
|
|
(err/rt-test (open-output-file "x" 8 one))
|
|
(err/rt-test (call-with-output-file "x" void one 'bad))
|
|
(err/rt-test (call-with-output-file "x" void one 8))
|
|
(err/rt-test (call-with-output-file "x" void 'bad one))
|
|
(err/rt-test (call-with-output-file "x" void 8 one))
|
|
(err/rt-test (with-output-to-file "x" void one 8))
|
|
(err/rt-test (with-output-to-file "x" void one 'bad))
|
|
(err/rt-test (with-output-to-file "x" void 8 one))
|
|
(err/rt-test (with-output-to-file "x" void 'bad one))
|
|
(for-each
|
|
(lambda (two)
|
|
(err/rt-test (open-output-file "x" one two) conflict?)
|
|
(err/rt-test (call-with-output-file "x" void one two) conflict?)
|
|
(err/rt-test (with-output-to-file "x" void one two) conflict?))
|
|
ones))
|
|
ones))
|
|
`(,modes ,replacement)))
|
|
(err/rt-test (open-output-file (build-path (current-directory) "baddir" "x"))
|
|
exn:fail:filesystem?)
|
|
|
|
(when (file-exists? "tmp4")
|
|
(delete-file "tmp4"))
|
|
(let ([p (open-output-file "tmp4")])
|
|
(err/rt-test (write-special 'foo p) exn:application:mismatch?)
|
|
(test #t integer? (port-file-identity p))
|
|
(let ([q (open-input-file "tmp4")])
|
|
(test (port-file-identity p) port-file-identity q)
|
|
(close-input-port q)
|
|
(err/rt-test (file-position q) exn:fail?)
|
|
(err/rt-test (port-file-identity q) exn:fail?))
|
|
(close-output-port p)
|
|
(err/rt-test (file-position p) exn:fail?)
|
|
(err/rt-test (port-file-identity p) exn:fail?))
|
|
(err/rt-test (let ([c (make-custodian)])
|
|
(let ([p (parameterize ([current-custodian c])
|
|
(open-output-file "tmp4" 'replace))])
|
|
(custodian-shutdown-all c)
|
|
(display 'hi p)))
|
|
exn:fail?)
|
|
(err/rt-test (open-output-file "tmp4" 'error) exn:fail:filesystem?)
|
|
(define p (open-output-file "tmp4" 'replace))
|
|
(display 7 p)
|
|
(display "" p)
|
|
(close-output-port p)
|
|
(close-output-port (open-output-file "tmp4" 'truncate))
|
|
(define p (open-input-file "tmp4"))
|
|
(test eof read p)
|
|
(close-input-port p)
|
|
(define p (open-output-file "tmp4" 'replace))
|
|
(display 7 p)
|
|
(close-output-port p)
|
|
(define p (open-output-file "tmp4" 'append))
|
|
(display 7 p)
|
|
(close-output-port p)
|
|
(err/rt-test (display 9 p) exn:fail?)
|
|
(err/rt-test (write 9 p) exn:fail?)
|
|
(err/rt-test (write-char #\a p) exn:fail?)
|
|
|
|
(err/rt-test (let ([c (make-custodian)])
|
|
(let ([p (parameterize ([current-custodian c])
|
|
(open-input-file "tmp4"))])
|
|
(custodian-shutdown-all c)
|
|
(read p)))
|
|
exn:fail?)
|
|
(define p (open-input-file "tmp4"))
|
|
(test 77 read p)
|
|
(close-input-port p)
|
|
(err/rt-test (read p) exn:fail?)
|
|
(err/rt-test (read-char p) exn:fail?)
|
|
(err/rt-test (char-ready? p) exn:fail?)
|
|
|
|
(define-values (in-p out-p) (open-input-output-file "tmp4" 'update))
|
|
(test #\7 read-char in-p)
|
|
(close-output-port out-p)
|
|
(test #\7 read-char in-p)
|
|
(test eof read-char in-p)
|
|
(close-input-port in-p)
|
|
|
|
(define p (open-output-file "tmp4" 'update))
|
|
(display 6 p)
|
|
(close-output-port p)
|
|
(test 2 file-size "tmp4")
|
|
(define p (open-input-file "tmp4"))
|
|
(test 67 read p)
|
|
(test eof read p)
|
|
(close-input-port p)
|
|
|
|
(define p (open-output-file "tmp4" 'update))
|
|
(file-position p 1)
|
|
(display 68 p)
|
|
(close-output-port p)
|
|
(test 3 file-size "tmp4")
|
|
(define p (open-input-file "tmp4"))
|
|
(test 0 file-position p)
|
|
(test 668 read p)
|
|
(test 3 file-position p)
|
|
(test eof read p)
|
|
(test 3 file-position p)
|
|
(file-position p 1)
|
|
(test 1 file-position p)
|
|
(test #\6 read-char p)
|
|
(test #\8 read-char p)
|
|
(file-position p 0)
|
|
(test 0 file-position p)
|
|
(test #\6 read-char p)
|
|
(test 1 file-position p)
|
|
(file-position p 2)
|
|
(test #\8 read-char p)
|
|
(test 3 file-position p)
|
|
(close-input-port p)
|
|
|
|
(close-output-port (open-output-file "tmp4" 'truncate/replace))
|
|
(define p (open-input-file "tmp4"))
|
|
(test eof read p)
|
|
(close-input-port p)
|
|
|
|
(define-values (in-p out-p) (open-input-output-file "tmp4" 'update))
|
|
(fprintf out-p "hi~n")
|
|
(flush-output out-p)
|
|
(test eof read-char in-p)
|
|
(test 3 file-position out-p)
|
|
(test 3 file-position in-p)
|
|
(file-position out-p 0)
|
|
(test 0 file-position out-p)
|
|
(test 0 file-position in-p)
|
|
(test #\h read-char in-p) ; might read more characters into a buffer!
|
|
(file-position out-p 1)
|
|
(close-input-port in-p)
|
|
(test 1 file-position out-p)
|
|
(write-char #\x out-p)
|
|
(close-output-port out-p)
|
|
(test 'hx with-input-from-file "tmp4" read)
|
|
|
|
(arity-test call-with-input-file 2 3)
|
|
(arity-test call-with-output-file 2 4)
|
|
(arity-test with-input-from-file 2 3)
|
|
(arity-test with-output-to-file 2 4)
|
|
|
|
(err/rt-test (call-with-input-file "x" 8))
|
|
(err/rt-test (call-with-input-file 8 (lambda (x) x)))
|
|
(err/rt-test (call-with-input-file 8 (lambda () 9)))
|
|
(err/rt-test (call-with-input-file "x" (lambda (x) x) 8))
|
|
(err/rt-test (call-with-input-file "x" (lambda (x) x) 'bad))
|
|
|
|
(err/rt-test (call-with-output-file "x" 8))
|
|
(err/rt-test (call-with-output-file 8 (lambda (x) x)))
|
|
(err/rt-test (call-with-output-file 8 (lambda () 9)))
|
|
(err/rt-test (call-with-output-file "x" (lambda (x) x) 8))
|
|
(err/rt-test (call-with-output-file "x" (lambda (x) x) 'bad))
|
|
|
|
(err/rt-test (with-input-from-file "x" 8))
|
|
(err/rt-test (with-input-from-file 8 (lambda () 9)))
|
|
(err/rt-test (with-input-from-file 8 (lambda (x) x)))
|
|
(err/rt-test (with-input-from-file "x" (lambda () 9) 8))
|
|
(err/rt-test (with-input-from-file "x" (lambda () 9) 'bad))
|
|
|
|
(err/rt-test (with-output-to-file "x" 8))
|
|
(err/rt-test (with-output-to-file 8 (lambda () 9)))
|
|
(err/rt-test (with-output-to-file 8 (lambda (x) x)))
|
|
(err/rt-test (with-output-to-file "x" (lambda () 9) 8))
|
|
(err/rt-test (with-output-to-file "x" (lambda () 9) 'bad))
|
|
|
|
(define s (open-output-string))
|
|
(test #f input-port? s)
|
|
(test #t output-port? s)
|
|
(let ([c (current-output-port)])
|
|
(current-output-port s)
|
|
(display 8)
|
|
(current-output-port c))
|
|
(test "8" get-output-string s)
|
|
(let ([c (current-error-port)])
|
|
(current-error-port s)
|
|
(display 9 (current-error-port))
|
|
(current-error-port c))
|
|
(test "89" get-output-string s)
|
|
(define s2 (open-input-string (get-output-string s)))
|
|
(test #t input-port? s2)
|
|
(test #f output-port? s2)
|
|
(test 89 + 0
|
|
(let ([c (current-input-port)])
|
|
(current-input-port s2)
|
|
(begin0
|
|
(read)
|
|
(current-input-port c))))
|
|
(test eof read s2)
|
|
|
|
(arity-test open-output-string 0 1)
|
|
(arity-test open-input-string 1 2)
|
|
(arity-test get-output-string 1 1)
|
|
|
|
(arity-test open-output-bytes 0 1)
|
|
(arity-test open-input-bytes 1 2)
|
|
(arity-test get-output-bytes 1 1)
|
|
|
|
(test 75 object-name (open-input-string "x" 75))
|
|
(test 76 object-name (open-input-bytes #"x" 76))
|
|
(test 175 object-name (open-output-string 175))
|
|
(test 176 object-name (open-output-bytes 176))
|
|
|
|
(err/rt-test (get-output-string 9))
|
|
(err/rt-test (get-output-string (current-output-port)))
|
|
|
|
(let ([p (open-input-string "a\nb")])
|
|
(test '(#f #f 1) call-with-values (lambda () (port-next-location p)) list)
|
|
(port-count-lines! p)
|
|
(test '(1 0 1) call-with-values (lambda () (port-next-location p)) list)
|
|
(test #\a read-char p)
|
|
(test '(1 1 2) call-with-values (lambda () (port-next-location p)) list)
|
|
(test '(1 1 2) call-with-values (lambda () (port-next-location p)) list)
|
|
(test #\newline peek-char p)
|
|
(test '(1 1 2) call-with-values (lambda () (port-next-location p)) list)
|
|
(test #\newline read-char p)
|
|
(test '(2 0 3) call-with-values (lambda () (port-next-location p)) list)
|
|
(test #\b peek-char p)
|
|
(test '(2 0 3) call-with-values (lambda () (port-next-location p)) list)
|
|
(test #\b read-char p)
|
|
(test '(2 1 4) call-with-values (lambda () (port-next-location p)) list)
|
|
(test eof read-char p)
|
|
(test '(2 1 4) call-with-values (lambda () (port-next-location p)) list)
|
|
(test eof read-char p)
|
|
(test '(2 1 4) call-with-values (lambda () (port-next-location p)) list))
|
|
|
|
(define-values (out in) (make-pipe))
|
|
(test #t input-port? out)
|
|
(test #t output-port? in)
|
|
(let loop ([n 1000])
|
|
(unless (zero? n)
|
|
(display n in)
|
|
(newline in)
|
|
(loop (sub1 n))))
|
|
(let loop ([n 999])
|
|
(unless (zero? n)
|
|
(read out)
|
|
(loop (sub1 n))))
|
|
(test 1 read out)
|
|
(close-output-port in)
|
|
(test eof read out)
|
|
(close-input-port out)
|
|
|
|
(define-values (in out) (make-pipe 3))
|
|
(test 3 write-bytes-avail #"12345" out)
|
|
(let ([s (make-bytes 5 (char->integer #\-))])
|
|
(test 3 read-bytes-avail! s in)
|
|
(test #"123--" values s))
|
|
(display 1 out)
|
|
(test 2 write-bytes-avail #"2345" out)
|
|
(let ([th1 (thread (lambda ()
|
|
(display "a" out)))]
|
|
[th2 (thread (lambda ()
|
|
(display "a" out)))]
|
|
[th3 (thread (lambda ()
|
|
(display "a" out)))])
|
|
(test #t thread-running? th1)
|
|
(test #t thread-running? th2)
|
|
(test #t thread-running? th3)
|
|
|
|
(test 49 read-byte in)
|
|
|
|
(sleep 0.1)
|
|
|
|
(test 2 +
|
|
(if (thread-running? th1) 1 0)
|
|
(if (thread-running? th2) 1 0)
|
|
(if (thread-running? th3) 1 0))
|
|
|
|
(test 50 read-byte in)
|
|
|
|
(sleep 0.1)
|
|
|
|
(test 1 +
|
|
(if (thread-running? th1) 1 0)
|
|
(if (thread-running? th2) 1 0)
|
|
(if (thread-running? th3) 1 0))
|
|
|
|
(test 51 read-byte in)
|
|
|
|
(sleep 0.1)
|
|
|
|
(test #f thread-running? th1)
|
|
(test #f thread-running? th2)
|
|
(test #f thread-running? th3)
|
|
|
|
(close-output-port out)
|
|
|
|
(test #"aaa" read-bytes 10 in))
|
|
(close-input-port in)
|
|
|
|
(arity-test write-bytes-avail 1 4)
|
|
(arity-test write-bytes-avail* 1 4)
|
|
(arity-test write-bytes-avail/enable-break 1 4)
|
|
|
|
(arity-test make-pipe 0 3)
|
|
(err/rt-test (make-pipe 0))
|
|
(err/rt-test (make-pipe -1))
|
|
(err/rt-test (make-pipe (- (expt 2 40))))
|
|
(err/rt-test (make-pipe "hello"))
|
|
|
|
(let-values ([(r w) (make-pipe #f 'in)])
|
|
(test 'in object-name r)
|
|
(test 'pipe object-name w))
|
|
(let-values ([(r w) (make-pipe #f 'in 'out)])
|
|
(test 'in object-name r)
|
|
(test 'out object-name w))
|
|
|
|
(test #t input-port? (make-input-port void void void void))
|
|
(test #t input-port? (make-input-port void void #f void))
|
|
(test #t input-port? (make-input-port 1000 void #f void))
|
|
(test 1000 object-name (make-input-port 1000 void #f void))
|
|
(err/rt-test (read (make-input-port #f void void void)))
|
|
(err/rt-test (read-char (make-input-port #f void void void)))
|
|
(err/rt-test (peek-char (make-input-port #f void void void)))
|
|
(arity-test make-input-port 4 10)
|
|
(err/rt-test (make-custom-input-port #f 8 void void))
|
|
(err/rt-test (make-custom-input-port #f void 8 void))
|
|
(err/rt-test (make-custom-input-port #f void void 8))
|
|
(err/rt-test (make-custom-input-port #f cons void void))
|
|
(err/rt-test (make-custom-input-port #f void add1 void))
|
|
(err/rt-test (make-custom-input-port #f void void add1))
|
|
|
|
(test #t output-port? (make-output-port #f always-evt void void))
|
|
(test #t output-port? (make-output-port #f always-evt void void))
|
|
(test 7786 object-name (make-output-port 7786 always-evt void void))
|
|
(arity-test make-output-port 4 11)
|
|
(err/rt-test (make-output-port #f 8 void void void))
|
|
(err/rt-test (make-output-port #f always-evt 8 void))
|
|
(err/rt-test (make-output-port #f always-evt void 8))
|
|
(err/rt-test (make-output-port #f always-evt add1 void))
|
|
(err/rt-test (make-output-port #f always-evt void add1))
|
|
(err/rt-test (write-special 'foo (make-custom-output-port void always-evt void void)) exn:application:mismatch?)
|
|
|
|
(let ([p (make-input-port
|
|
'name
|
|
(lambda (s) (bytes-set! s 0 97) 1)
|
|
(lambda (s skip progress-evt)
|
|
(test 0 'skip-is-0 skip)
|
|
(bytes-set! s 0 98) 1)
|
|
void)])
|
|
(test #\a read-char p)
|
|
(test #\b peek-char p)
|
|
(test #\a read-char p)
|
|
(test #\b peek-char p)
|
|
(test #\b peek-char p)
|
|
(test #\a read-char p)
|
|
(test 3 file-position p))
|
|
|
|
(let* ([s (open-input-string "(apple \"banana\" [coconut])")]
|
|
[p (make-input-port
|
|
'name
|
|
(lambda (str)
|
|
(if (or (byte-ready? s)
|
|
(zero? (random 2)))
|
|
(begin
|
|
(bytes-set! str 0 (read-byte s))
|
|
1)
|
|
s))
|
|
(lambda (str skip progress-evt)
|
|
(if (or (byte-ready? s)
|
|
(zero? (random 2)))
|
|
(begin
|
|
(bytes-set! str 0 (peek-byte s))
|
|
1)
|
|
s))
|
|
void)])
|
|
(test '(apple "banana" [coconut]) read p))
|
|
|
|
(let ([test-file (open-output-file "tmp2" 'truncate)])
|
|
(test 7 write-string (make-string 7 #\a) test-file)
|
|
(test 4095 write-string (make-string 4095 #\b) test-file)
|
|
(test 4096 write-string (make-string 4096 #\c) test-file)
|
|
(test 4097 write-string (make-string 4097 #\d) test-file)
|
|
(test (+ 7 4095 4096 4097) file-position test-file)
|
|
(close-output-port test-file)
|
|
(test (+ 7 4095 4096 4097) file-size "tmp2"))
|
|
|
|
(let ([go
|
|
(lambda (write-bytes)
|
|
(let ([test-file (open-output-file "tmp2" 'truncate)])
|
|
(test 7 write-bytes-avail (make-bytes 7 97) test-file)
|
|
(test 4095 write-bytes (make-bytes 4095 98) test-file)
|
|
(test 4096 write-bytes (make-bytes 4096 99) test-file)
|
|
(test 4097 write-bytes (make-bytes 4097 100) test-file)
|
|
(test (+ 7 4095 4096 4097) file-position test-file)
|
|
(close-output-port test-file)
|
|
(test (+ 7 4095 4096 4097) file-size "tmp2")))])
|
|
(go write-bytes)
|
|
(go write-bytes-avail)
|
|
(go write-bytes-avail*))
|
|
|
|
(let ([p (open-input-file "tmp1")]
|
|
[q (open-input-file "tmp2")])
|
|
(test #f = (port-file-identity p) (port-file-identity q))
|
|
(close-input-port p)
|
|
(close-input-port q))
|
|
|
|
(define test-file
|
|
(open-output-file "tmp2" 'truncate))
|
|
(write-char #\; test-file)
|
|
(display write-test-obj test-file)
|
|
(newline test-file)
|
|
(write load-test-obj test-file)
|
|
(test #t output-port? test-file)
|
|
(close-output-port test-file)
|
|
(check-test-file "tmp2")
|
|
|
|
(define ui (make-input-port 'name (lambda (s) (bytes-set! s 0 (char->integer #\")) 1) #f void))
|
|
(test "" read ui)
|
|
(arity-test (port-read-handler ui) 1 2)
|
|
(err/rt-test ((port-read-handler ui) 8))
|
|
(let ([old (port-read-handler ui)])
|
|
(port-read-handler ui (case-lambda [(x) "hello"][(x y) "goodbye"]))
|
|
(test "hello" read ui)
|
|
(port-read-handler ui old)
|
|
(test "" read ui))
|
|
(arity-test port-read-handler 1 2)
|
|
(err/rt-test (port-read-handler 1))
|
|
(err/rt-test (port-read-handler ui 8))
|
|
(err/rt-test (port-read-handler (current-output-port) 8))
|
|
(err/rt-test (port-read-handler ui (lambda () 9)))
|
|
(err/rt-test (port-read-handler ui (lambda (x) 9)))
|
|
(err/rt-test (port-read-handler ui (lambda (x y) 9)))
|
|
(err/rt-test (port-read-handler ui (lambda (x y z) 9)))
|
|
|
|
(define sp (open-output-string))
|
|
(test (void) display "hello" sp)
|
|
(test "hello" get-output-string sp)
|
|
(test (void) write "hello" sp)
|
|
(test "hello\"hello\"" get-output-string sp)
|
|
(arity-test (port-display-handler sp) 2 2)
|
|
(arity-test (port-write-handler sp) 2 2)
|
|
(arity-test (port-print-handler sp) 2 2)
|
|
(err/rt-test ((port-display-handler sp) 8 8))
|
|
(err/rt-test ((port-write-handler sp) 8 8))
|
|
(err/rt-test ((port-print-handler sp) 8 8))
|
|
(let ([oldd (port-display-handler sp)]
|
|
[oldw (port-write-handler sp)]
|
|
[oldp (port-print-handler sp)]
|
|
[adding (let ([s "hello\"hello\""])
|
|
(lambda (a)
|
|
(set! s (string-append s a))
|
|
s))])
|
|
(port-display-handler sp (lambda (v p) (oldd "X" p) (values 1 2)))
|
|
(test (void) display "hello" sp)
|
|
(test (adding "X") get-output-string sp)
|
|
(test (void) write "hello" sp)
|
|
(test (adding "\"hello\"") get-output-string sp)
|
|
(test (void) print "hello" sp)
|
|
(test (adding "\"hello\"") get-output-string sp)
|
|
|
|
(port-write-handler sp (lambda (v p) (oldd "Y" p) 5))
|
|
(test (void) display "hello" sp)
|
|
(test (adding "X") get-output-string sp)
|
|
(test (void) write "hello" sp)
|
|
(test (adding "Y") get-output-string sp)
|
|
(test (void) print "hello" sp)
|
|
(test (adding "\"hello\"") get-output-string sp)
|
|
(parameterize ([global-port-print-handler display])
|
|
(test (void) print "hello" sp)
|
|
(test (adding "X") get-output-string sp))
|
|
(parameterize ([global-port-print-handler oldd])
|
|
(test (void) print "hello" sp)
|
|
(test (adding "hello") get-output-string sp))
|
|
(test (void) print "hello" sp)
|
|
(test (adding "\"hello\"") get-output-string sp)
|
|
|
|
|
|
(port-print-handler sp (lambda (v p) (oldd "Z" p) 5))
|
|
(test (void) display "hello" sp)
|
|
(test (adding "X") get-output-string sp)
|
|
(test (void) write "hello" sp)
|
|
(test (adding "Y") get-output-string sp)
|
|
(test (void) print "hello" sp)
|
|
(test (adding "Z") get-output-string sp)
|
|
(parameterize ([global-port-print-handler display])
|
|
(test (void) print "hello" sp)
|
|
(test (adding "Z") get-output-string sp))
|
|
(test (void) print "hello" sp)
|
|
(test (adding "Z") get-output-string sp)
|
|
|
|
(port-display-handler sp oldd)
|
|
(test (void) display "hello" sp)
|
|
(test (adding "hello") get-output-string sp)
|
|
(test (void) write "hello" sp)
|
|
(test (adding "Y") get-output-string sp)
|
|
|
|
(port-write-handler sp oldw)
|
|
(test (void) display "hello" sp)
|
|
(test (adding "hello") get-output-string sp)
|
|
(test (void) write "hello" sp)
|
|
(test (adding "\"hello\"") get-output-string sp)
|
|
|
|
(port-display-handler sp oldw)
|
|
(port-write-handler sp oldd)
|
|
(port-print-handler sp oldp)
|
|
(test (void) display "hello" sp)
|
|
(test (adding "\"hello\"") get-output-string sp)
|
|
(test (void) write "hello" sp)
|
|
(test (adding "hello") get-output-string sp)
|
|
(test (void) print "goodbye" sp)
|
|
(test (adding "\"goodbye\"") get-output-string sp)
|
|
(port-display-handler sp oldd)
|
|
(port-write-handler sp oldw))
|
|
(err/rt-test (port-display-handler 1))
|
|
(err/rt-test (port-display-handler sp 8))
|
|
(err/rt-test (port-display-handler (current-input-port) 8))
|
|
(err/rt-test (port-display-handler sp (lambda (x) 9)))
|
|
(err/rt-test (port-display-handler sp (lambda (x y z) 9)))
|
|
(err/rt-test (port-write-handler 1))
|
|
(err/rt-test (port-write-handler sp 8))
|
|
(err/rt-test (port-write-handler (current-input-port) 8))
|
|
(err/rt-test (port-write-handler sp (lambda (x) 9)))
|
|
(err/rt-test (port-write-handler sp (lambda (x y z) 9)))
|
|
|
|
;;------------------------------------------------------------
|
|
;; peek-string and variants:
|
|
|
|
(let ([p (open-input-string "Hello World!")])
|
|
(test "World!" peek-string 6 6 p)
|
|
(test "World!" peek-string 7 6 p)
|
|
(test "He" read-string 2 p)
|
|
(test "rld!" peek-string 7 6 p)
|
|
(test eof peek-string 7 600 p))
|
|
|
|
(define (test-a-port p go sync)
|
|
(let* ([s (bytes 49 50 51)]
|
|
[reset-s! (lambda ()
|
|
(bytes-set! s 0 49)
|
|
(bytes-set! s 1 50)
|
|
(bytes-set! s 2 51))]
|
|
[test-empty (lambda()
|
|
(test #f byte-ready? p)
|
|
(test 0 peek-bytes-avail!* s 0 #f p)
|
|
(test 0 peek-bytes-avail!* s 1 #f p)
|
|
(test 0 read-bytes-avail!* s p))])
|
|
(test-empty)
|
|
|
|
(test 0 peek-bytes-avail!* s 500 #f p)
|
|
(test 0 read-bytes-avail!* s p)
|
|
|
|
(let ([test-basic
|
|
(lambda (str sync?)
|
|
(go)
|
|
(when sync?
|
|
(sync p)
|
|
(test #t byte-ready? p)
|
|
(test 1 peek-bytes-avail!* s 0 #f p)
|
|
(test str values s)
|
|
(reset-s!))
|
|
(test 1 peek-bytes-avail! s 0 #f p)
|
|
(test str values s)
|
|
(reset-s!)
|
|
(test 1 peek-bytes-avail!* s 0 #f p)
|
|
(test str values s)
|
|
(reset-s!)
|
|
(test 1 read-bytes-avail!* s p)
|
|
(test str values s)
|
|
(reset-s!))])
|
|
(test-basic #"A23" #t)
|
|
(test-basic #"B23" #f))
|
|
|
|
(test-empty)
|
|
|
|
(go) (go)
|
|
|
|
(let ([peek0
|
|
(lambda ()
|
|
(let ([avail (peek-bytes-avail! s 0 #f p)])
|
|
(cond
|
|
[(= avail 1) (test #"C23" values s)]
|
|
[(= avail 2) (test #"CD3" values s)]
|
|
[else (test 1-or-2 values avail)])))])
|
|
(peek0)
|
|
(reset-s!)
|
|
(test 1 peek-bytes-avail! s 1 #f p)
|
|
(test #"D23" values s)
|
|
(reset-s!)
|
|
(peek0)
|
|
(reset-s!)
|
|
(test 0 peek-bytes-avail!* s 2 #f p)
|
|
(test 2 read-bytes-avail! s p)
|
|
(test #"CD3" values s)
|
|
|
|
(test-empty)
|
|
|
|
(go) (go) (go)
|
|
(test #"E" peek-bytes 1 0 p)
|
|
(test #"F" peek-bytes 1 1 p)
|
|
(test #"G" peek-bytes 1 2 p)
|
|
(test 0 peek-bytes-avail!* s 3 #f p)
|
|
(test #"EFG" read-bytes 3 p)
|
|
|
|
(test-empty)
|
|
|
|
(go) (go) (go)
|
|
(test #"HI" peek-bytes 2 0 p)
|
|
(test #"IJ" peek-bytes 2 1 p)
|
|
(test #"J" peek-bytes 1 2 p)
|
|
(test 0 peek-bytes-avail!* s 3 #f p)
|
|
(test #"HI" read-bytes 2 p)
|
|
(test #"J" read-bytes 1 p)
|
|
|
|
(test-empty)
|
|
|
|
(go) (go) (go)
|
|
(test #"KLM" peek-bytes 3 0 p)
|
|
(test #"LM" peek-bytes 2 1 p)
|
|
(test #"M" peek-bytes 1 2 p)
|
|
(test #"K" read-bytes 1 p)
|
|
(test #"L" read-bytes 1 p)
|
|
(test #"M" read-bytes 1 p)
|
|
|
|
(test-empty))))
|
|
|
|
(define (gdelay go)
|
|
(lambda ()
|
|
(thread go)))
|
|
|
|
(define (gsync port)
|
|
(sync port))
|
|
|
|
;; Test custom port with test-a-port
|
|
(define (test-a-custom-port supply-peek? gdelay gsync)
|
|
(let* ([counter 0]
|
|
[lock (make-semaphore 1)]
|
|
[ready-sema (make-semaphore)]
|
|
[extras null]
|
|
[go (lambda ()
|
|
(semaphore-wait lock)
|
|
(semaphore-post ready-sema)
|
|
(for-each semaphore-post extras)
|
|
(set! extras null)
|
|
(semaphore-post lock))]
|
|
[p (make-input-port
|
|
'name
|
|
;; read-bytes:
|
|
(lambda (s)
|
|
(if (semaphore-try-wait? lock)
|
|
(begin0
|
|
(let loop ([got 0])
|
|
(if (and (got . < . (bytes-length s))
|
|
(semaphore-try-wait? ready-sema))
|
|
(begin
|
|
(bytes-set! s got (+ 65 counter))
|
|
(set! counter (add1 counter))
|
|
(loop (add1 got)))
|
|
(if (zero? got)
|
|
(wrap-evt
|
|
(semaphore-peek-evt ready-sema)
|
|
(lambda (x) 0))
|
|
got)))
|
|
(semaphore-post lock))
|
|
(wrap-evt
|
|
(semaphore-peek-evt lock)
|
|
(lambda (x) 0))))
|
|
(and supply-peek?
|
|
(lambda (s d progress-evt)
|
|
(if (semaphore-try-wait? lock)
|
|
(begin0
|
|
(let loop ([d d][counter counter])
|
|
(if (semaphore-try-wait? ready-sema)
|
|
(begin0
|
|
(cond
|
|
[(zero? d)
|
|
(bytes-set! s 0 (+ 65 counter))
|
|
1]
|
|
[else
|
|
(loop (sub1 d) (add1 counter))])
|
|
(semaphore-post ready-sema))
|
|
;; Provide a new semaphore to be posted
|
|
;; when new things appear:
|
|
(let ([s (make-semaphore)])
|
|
(set! extras (cons s extras))
|
|
(wrap-evt s (lambda (x) 0)))))
|
|
(semaphore-post lock))
|
|
(wrap-evt
|
|
(semaphore-peek-evt lock)
|
|
(lambda () 0)))))
|
|
void)])
|
|
(test-a-port p (gdelay go) gsync)))
|
|
|
|
(test-a-custom-port #f values void)
|
|
(test-a-custom-port #t values void)
|
|
(test-a-custom-port #f gdelay gsync)
|
|
(test-a-custom-port #t gdelay gsync)
|
|
|
|
;; Pipe
|
|
(define (test-a-pipe gdelay gsync)
|
|
(let-values ([(r w) (make-pipe)])
|
|
(let* ([counter 0]
|
|
[go (lambda ()
|
|
(write-byte (+ 65 counter) w)
|
|
(set! counter (add1 counter)))])
|
|
(test-a-port r (gdelay go) gsync))))
|
|
|
|
(test-a-pipe values void)
|
|
(test-a-pipe gdelay gsync)
|
|
|
|
(arity-test read-bytes 1 2)
|
|
(arity-test peek-bytes 2 3)
|
|
(arity-test read-string 1 2)
|
|
(arity-test peek-string 2 3)
|
|
(arity-test read-bytes! 1 4)
|
|
(arity-test peek-bytes! 2 5)
|
|
(arity-test read-string! 1 4)
|
|
(arity-test peek-string! 2 5)
|
|
(arity-test read-bytes-avail! 1 4)
|
|
(arity-test peek-bytes-avail! 2 6)
|
|
(arity-test read-bytes-avail!* 1 4)
|
|
(arity-test peek-bytes-avail!* 2 6)
|
|
(arity-test read-bytes-avail!/enable-break 1 4)
|
|
(arity-test peek-bytes-avail!/enable-break 2 6)
|
|
|
|
(let ([fill-a
|
|
(lambda (s pos)
|
|
(let ([l (bytes-length s)])
|
|
(let loop ([i 0])
|
|
(unless (= i l)
|
|
(bytes-set! s i (+ 48 (modulo (+ i pos) 10)))
|
|
(loop (add1 i))))
|
|
l))]
|
|
[pos 0])
|
|
(let ([p (make-input-port
|
|
'name
|
|
(lambda (s) (let ([n (fill-a s pos)])
|
|
(set! pos (+ pos n))
|
|
n))
|
|
(lambda (s skip progress-evt) (fill-a s (+ pos skip)))
|
|
void)])
|
|
(test 48 read-byte p)
|
|
(test 49 peek-byte p)
|
|
(test 49 read-byte p)
|
|
(test #"234" read-bytes 3 p)
|
|
(test #"567" peek-bytes 3 0 p)
|
|
(test #"567890" read-bytes 6 p)
|
|
(test #"123" peek-bytes 3 500 p)
|
|
(test #"123" peek-bytes 3 (expt 10 100) p)
|
|
(test #"567" peek-bytes 3 (+ 4 (expt 10 100)) p)
|
|
(test #f regexp-match #"11" p 0 10000)
|
|
(test #"123" read-bytes 3 p)
|
|
(test '(#"0") regexp-match #"0" p 0)
|
|
(let ([x (+ 9 (expt 10 100))])
|
|
(test (list (cons x (add1 x))) regexp-match-peek-positions #"0" p (expt 10 100)))))
|
|
|
|
;;------------------------------------------------------------
|
|
|
|
;; Test custom output port
|
|
(let ([l null]
|
|
[s (make-semaphore)]
|
|
[flushed? #f]
|
|
[spec #f])
|
|
(let ([p (make-output-port
|
|
'name
|
|
(semaphore-peek-evt s)
|
|
(lambda (bytes start end non-block? breakable?)
|
|
(define can-block? (not non-block?))
|
|
(let loop ()
|
|
(if (= start end)
|
|
(begin
|
|
(set! flushed? #t)
|
|
0)
|
|
(if (if can-block?
|
|
(semaphore-wait s)
|
|
(semaphore-try-wait? s))
|
|
(let ([len (if can-block?
|
|
(- end start)
|
|
1)])
|
|
(set! l (append l
|
|
(list (subbytes bytes start (+ start len)))))
|
|
len)
|
|
(wrap-evt (semaphore-peek-evt s)
|
|
(lambda (x) (loop)))))))
|
|
(lambda ()
|
|
(set! l #f))
|
|
(lambda (s non-block? breakable?)
|
|
(set! spec s)
|
|
(not non-block?)))])
|
|
(test 0 write-bytes-avail* #"abc" p)
|
|
(semaphore-post s)
|
|
(test 3 write-bytes #"abc" p)
|
|
(test '(#"abc") values l)
|
|
(semaphore-post s)
|
|
(let ([n (write-bytes-avail #"abc" p)])
|
|
(test #t <= n 1 3)
|
|
(test (add1 n) length l))
|
|
(flush-output p)
|
|
(test #t values flushed?)
|
|
(test #f write-special-avail* 'thing p)
|
|
(test 'thing values spec)
|
|
(test #t write-special 'thung p)
|
|
(test 'thung values spec)
|
|
(test (void) close-output-port p)
|
|
(test #f values l)
|
|
(set! l 10)
|
|
(test (void) close-output-port p)
|
|
(test 10 values l)))
|
|
|
|
; --------------------------------------------------
|
|
|
|
(SECTION 6 10 4)
|
|
(load "tmp1")
|
|
(test write-test-obj 'load foo)
|
|
|
|
(SECTION 'INEXACT-I/IO)
|
|
(define wto write-test-obj)
|
|
(define dto display-test-obj)
|
|
(define lto load-test-obj)
|
|
(define f-3.25 (string->number "-3.25"))
|
|
(define f.25 (string->number ".25"))
|
|
(set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
|
|
(set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
|
|
(set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
|
|
(let ([f (lambda (test-file)
|
|
(write-char #\; test-file)
|
|
(display write-test-obj test-file)
|
|
(newline test-file)
|
|
(write load-test-obj test-file)
|
|
(output-port? test-file))])
|
|
(test #t call-with-output-file
|
|
"tmp3" f 'truncate))
|
|
(check-test-file "tmp3")
|
|
(set! write-test-obj wto)
|
|
(set! display-test-obj dto)
|
|
(set! load-test-obj lto)
|
|
|
|
(define badc-range-start 0)
|
|
(define badc-range-end 255)
|
|
|
|
(SECTION 'PRINTF)
|
|
(define (test-format format)
|
|
(test "~" format "~~")
|
|
(test "hello---~---there" format "~a---~~---~a" "hello" 'there)
|
|
(test "\"hello\"---~---there" format "~s---~~---~s" "hello" 'there)
|
|
(test "\"hello\"---~---there" format "~v---~~---~v" "hello" 'there)
|
|
(test (string #\a #\newline #\b #\newline #\c) format "a~nb~%c")
|
|
(let ([try-newline-stuff
|
|
(lambda (newlines)
|
|
(test "12" format (apply string `(#\1 #\~ #\space ,@newlines #\space #\2)))
|
|
(test "12" format (apply string `(#\1 #\~ ,@newlines #\space #\2)))
|
|
(test "12" format (apply string `(#\1 #\~ ,@newlines #\2)))
|
|
(test (apply string `(#\1 ,@newlines #\2))
|
|
format (apply string `(#\1 #\~ ,@newlines #\space ,@newlines #\2))))])
|
|
(for-each try-newline-stuff '((#\return) (#\newline) (#\return #\newline))))
|
|
(test "twenty=20..." format "twenty=~s..." 20)
|
|
(test "twenty=20..." format "twenty=~v..." 20)
|
|
(test "twenty=20..." format "twenty=~e..." 20)
|
|
(test "twenty=14..." format "twenty=~x..." 20)
|
|
(test "twenty=24..." format "twenty=~o..." 20)
|
|
(test "twenty=10100..." format "twenty=~b..." 20)
|
|
(test "zee=z..." format "zee=~c..." #\z)
|
|
|
|
(test #\.
|
|
(lambda (s) (string-ref s (sub1 (string-length s))))
|
|
(parameterize ([error-print-width 40])
|
|
(format "~e" (make-string 200 #\v))))
|
|
|
|
(let()
|
|
(define bads
|
|
(let loop ([i badc-range-end])
|
|
(cond
|
|
[(eq? i badc-range-start) (list (integer->char i))]
|
|
[else (let ([c (integer->char i)]
|
|
[rest (loop (sub1 i))])
|
|
(case c
|
|
[(#\~ #\% #\n #\a #\s #\c #\o #\x #\b #\v #\e
|
|
#\N #\A #\S #\C #\O #\X #\B #\V #\E)
|
|
rest]
|
|
[else (if (char-whitespace? c)
|
|
rest
|
|
(cons c rest))]))])))
|
|
|
|
(define with-censor (load-relative "censor.ss"))
|
|
|
|
; test for all bad tags; the string we generate shouldn't
|
|
; be printed to a terminal directly because it can contain contain
|
|
; control characters; censor it
|
|
(unless building-flat-tests?
|
|
(with-censor
|
|
(lambda ()
|
|
(for-each (lambda (c)
|
|
(err/rt-test (format (format "a~~~cb" c) 0)))
|
|
bads)))))
|
|
|
|
(err/rt-test (format 9))
|
|
(err/rt-test (format "apple~"))
|
|
(err/rt-test (format "~"))
|
|
(err/rt-test (format "~~~"))
|
|
(err/rt-test (format "~o") exn:application:mismatch?)
|
|
(err/rt-test (format "~o" 1 2) exn:application:mismatch?)
|
|
(err/rt-test (format "~c" 1) exn:application:mismatch?)
|
|
(err/rt-test (format "~x" 'a) exn:application:mismatch?)
|
|
(err/rt-test (format "~x" 4.0) exn:application:mismatch?)
|
|
(err/rt-test (format "~x" 5+4.0i) exn:application:mismatch?))
|
|
|
|
(test-format format)
|
|
(test-format
|
|
(lambda args
|
|
(let ([p (open-output-string)])
|
|
(apply fprintf p args)
|
|
(get-output-string p))))
|
|
(test-format
|
|
(lambda args
|
|
(let ([p (open-output-string)])
|
|
(parameterize ([current-output-port p])
|
|
(apply printf args))
|
|
(get-output-string p))))
|
|
|
|
(arity-test format 1 -1)
|
|
(arity-test printf 1 -1)
|
|
(arity-test fprintf 2 -1)
|
|
|
|
(define success-1? (putenv "APPLE" "AnApple"))
|
|
(define success-2? (putenv "BANANA" "AnotherApple"))
|
|
(err/rt-test (getenv 7))
|
|
(err/rt-test (getenv (string #\a #\nul #\b)))
|
|
(err/rt-test (putenv 7 "hi"))
|
|
(err/rt-test (putenv "hi" 7))
|
|
(err/rt-test (putenv (string #\a #\nul #\b) "hi"))
|
|
(err/rt-test (putenv "hi" (string #\a #\nul #\b)))
|
|
(collect-garbage)
|
|
(test #t 'success-1 success-1?)
|
|
(test #t 'success-2 success-2?)
|
|
(test "AnApple" getenv "APPLE")
|
|
(test "AnotherApple" getenv "BANANA")
|
|
(test #f getenv "AnUndefinedEnvironmentVariable")
|
|
|
|
(arity-test getenv 1 1)
|
|
(arity-test putenv 2 2)
|
|
|
|
(arity-test read-eval-print-loop 0 0)
|
|
(test (void) 'r-e-p-l-return
|
|
(parameterize ([current-input-port (make-input-port
|
|
'name
|
|
(lambda (s) eof)
|
|
#f
|
|
void)])
|
|
(read-eval-print-loop)))
|
|
|
|
|
|
|
|
(define (cust-test open)
|
|
(let ([try
|
|
(lambda ()
|
|
(let ([c (make-custodian)])
|
|
(parameterize ([current-custodian c])
|
|
(let ([n
|
|
(let loop ([n 0])
|
|
(with-handlers ([exn:fail:filesystem?
|
|
(lambda (exn)
|
|
(printf "expected open failure: ~a~n"
|
|
(exn-message exn))
|
|
n)])
|
|
;; leave the port open:
|
|
(open)
|
|
(if (= n 5000)
|
|
n
|
|
(loop (add1 n)))))])
|
|
;; should close all the ports
|
|
(custodian-shutdown-all c)
|
|
(printf "got ~a ports~n" n)
|
|
n))))])
|
|
(let ([n (try)])
|
|
(test n try))))
|
|
|
|
(unless (eq? 'macos (system-type)) ;; no limit in Mac OS Classic!
|
|
(cust-test (lambda ()
|
|
(open-input-file
|
|
(build-path (current-load-relative-directory)
|
|
"file.ss")))))
|
|
|
|
;; Too time-consuming, does bad things to the network:
|
|
'(let* ([pn 40001]
|
|
[l (tcp-listen pn)])
|
|
(cust-test (lambda ()
|
|
(let-values ([(r1 w1) (tcp-connect "localhost" pn)]
|
|
[(r2 w2) (tcp-accept l)])
|
|
'(close-input-port r1)
|
|
'(close-output-port w1)
|
|
'(close-output-port w2)
|
|
'(close-input-port r2))))
|
|
(tcp-close l))
|
|
|
|
;;----------------------------------------------------------------------
|
|
;; TCP
|
|
|
|
(let ([do-once
|
|
(lambda (evt?)
|
|
(let* ([pn 40001]
|
|
[l (tcp-listen pn 5 #t)])
|
|
(let-values ([(r1 w1) (tcp-connect "localhost" pn)]
|
|
[(r2 w2) (if evt?
|
|
(apply values (sync (tcp-accept-evt l)))
|
|
(tcp-accept l))])
|
|
(test #t tcp-port? r1)
|
|
(test #t tcp-port? r2)
|
|
(test #t tcp-port? w1)
|
|
(test #t tcp-port? w2)
|
|
(fprintf w1 "Hello~n")
|
|
(flush-output w1)
|
|
(test "Hello" read-line r2)
|
|
(tcp-abandon-port r1)
|
|
(close-output-port w1)
|
|
(close-output-port w2)
|
|
(close-input-port r2))
|
|
(when evt?
|
|
(test #f sync/timeout 0 (tcp-accept-evt l)))
|
|
(tcp-close l)))])
|
|
(do-once #f)
|
|
(do-once #t))
|
|
|
|
(test #f tcp-port? (current-input-port))
|
|
(test #f tcp-port? (current-output-port))
|
|
|
|
(arity-test tcp-port? 1 1)
|
|
|
|
;;----------------------------------------------------------------------
|
|
;; UDP
|
|
|
|
(unless (eq? 'macos (system-type))
|
|
(load-relative "udp.ss"))
|
|
|
|
(when (eq? 'macos (system-type))
|
|
(err/rt-test (udp-open-socket) exn:misc:unsupported?)
|
|
;; All others fail b/c can't supply a UDP.
|
|
)
|
|
|
|
(test #f udp? 5)
|
|
|
|
;; more type tests in udp.ss, where we have UDP socket values
|
|
(err/rt-test (udp-close 5))
|
|
(err/rt-test (udp-bound? 5))
|
|
(err/rt-test (udp-connected? 5))
|
|
(err/rt-test (udp-bind! 5 #f 40000))
|
|
(err/rt-test (udp-connect! 5 "localhost" 40000))
|
|
(err/rt-test (udp-send-to 5 "localhost" 40000 #"hello"))
|
|
(err/rt-test (udp-send-to* 5 "localhost" 40000 #"hello"))
|
|
(err/rt-test (udp-send-to/enable-break 5 "localhost" 40000 #"hello"))
|
|
(err/rt-test (udp-send 5 #"hello"))
|
|
(err/rt-test (udp-send* 5 #"hello"))
|
|
(err/rt-test (udp-send/enable-break 5 #"hello"))
|
|
(err/rt-test (udp-receive! 5 (make-bytes 10)))
|
|
(err/rt-test (udp-receive!* 5 (make-bytes 10)))
|
|
(err/rt-test (udp-receive!/enable-break 5 (make-bytes 10)))
|
|
(err/rt-test (udp-receive!-evt 5 (make-bytes 10)))
|
|
(err/rt-test (udp-send-ready-evt 5))
|
|
(err/rt-test (udp-receive-ready-evt 5))
|
|
|
|
(arity-test udp-open-socket 0 2)
|
|
(arity-test udp-close 1 1)
|
|
(arity-test udp? 1 1)
|
|
(arity-test udp-bound? 1 1)
|
|
(arity-test udp-connected? 1 1)
|
|
(arity-test udp-bind! 3 3)
|
|
(arity-test udp-connect! 3 3)
|
|
(arity-test udp-send-to 4 6)
|
|
(arity-test udp-send-to* 4 6)
|
|
(arity-test udp-send-to/enable-break 4 6)
|
|
(arity-test udp-send 2 4)
|
|
(arity-test udp-send* 2 4)
|
|
(arity-test udp-send/enable-break 2 4)
|
|
(arity-test udp-send-to-evt 4 6)
|
|
(arity-test udp-send-evt 2 4)
|
|
(arity-test udp-receive! 2 4)
|
|
(arity-test udp-receive!* 2 4)
|
|
(arity-test udp-receive!/enable-break 2 4)
|
|
(arity-test udp-receive!-evt 2 4)
|
|
(arity-test udp-send-ready-evt 1 1)
|
|
(arity-test udp-receive-ready-evt 1 1)
|
|
|
|
(SECTION 'file-after-udp)
|
|
|
|
;;----------------------------------------------------------------------
|
|
;; Security guards:
|
|
|
|
;; Files - - - - - - - - - - - - - - - - - - - - - -
|
|
|
|
(define (make-file-sg ok-modes)
|
|
(make-security-guard (current-security-guard)
|
|
(lambda (who path modes)
|
|
(unless (andmap (lambda (m) (memq m ok-modes))
|
|
modes)
|
|
(raise (cons 'fs-reject who))))
|
|
void))
|
|
(define (fs-reject? who)
|
|
(lambda (x) (and (pair? x)
|
|
(eq? (car x) 'fs-reject)
|
|
(eq? (cdr x) who))))
|
|
|
|
(parameterize ([current-security-guard (make-file-sg '(exists read))])
|
|
(test #t path? (expand-path "tmp1"))
|
|
(test #t file-exists? "tmp1")
|
|
(test #f directory-exists? "tmp1")
|
|
(test #f link-exists? "tmp1")
|
|
|
|
(err/rt-test (open-output-file "tmp1") (fs-reject? 'open-output-file))
|
|
(err/rt-test (delete-file "tmp1") (fs-reject? 'delete-file))
|
|
(err/rt-test (rename-file-or-directory "tmp1" "tmp11") (fs-reject? 'rename-file-or-directory))
|
|
(err/rt-test (copy-file "tmp1" "tmp11") (fs-reject? 'copy-file))
|
|
(let ([p (open-input-file "tmp1")])
|
|
(test #t input-port? p)
|
|
(close-input-port p))
|
|
(test #t list? (directory-list)))
|
|
|
|
(parameterize ([current-security-guard (make-file-sg '(exists write))])
|
|
(test #t path? (expand-path "tmp1"))
|
|
(err/rt-test (open-input-file "tmp1") (fs-reject? 'open-input-file))
|
|
(err/rt-test (open-output-file "tmp1" 'append) (fs-reject? 'open-output-file))
|
|
(err/rt-test (open-output-file "tmp1" 'update) (fs-reject? 'open-output-file))
|
|
(err/rt-test (directory-list) (fs-reject? 'directory-list))
|
|
(err/rt-test (directory-list (current-directory)) (fs-reject? 'directory-list))
|
|
(err/rt-test (delete-directory (current-directory)) (fs-reject? 'delete-directory))
|
|
(err/rt-test (rename-file-or-directory "tmp1" "tmp11") (fs-reject? 'rename-file-or-directory))
|
|
(err/rt-test (copy-file "tmp1" "tmp11") (fs-reject? 'copy-file))
|
|
(err/rt-test (file-or-directory-modify-seconds "tmp1") (fs-reject? 'file-or-directory-modify-seconds))
|
|
(err/rt-test (file-or-directory-permissions "tmp1") (fs-reject? 'file-or-directory-permissions))
|
|
(err/rt-test (file-size "tmp1") (fs-reject? 'file-size)))
|
|
|
|
(parameterize ([current-security-guard (make-file-sg '(read write))])
|
|
(err/rt-test (current-directory) (fs-reject? 'current-directory))
|
|
(err/rt-test (current-directory "tmp1") (fs-reject? 'current-directory))
|
|
(err/rt-test (current-drive) (lambda (x)
|
|
(or (exn:unsupported? x) ((fs-reject? 'current-drive) x))))
|
|
(err/rt-test (expand-path "tmp1") (fs-reject? 'expand-path))
|
|
(err/rt-test (resolve-path "tmp1") (fs-reject? 'resolve-path))
|
|
(err/rt-test (simplify-path "../tmp1") (fs-reject? 'simplify-path))
|
|
(err/rt-test (file-exists? "tmp1") (fs-reject? 'file-exists?))
|
|
(err/rt-test (directory-exists? "tmp1") (fs-reject? 'directory-exists?))
|
|
(err/rt-test (link-exists? "tmp1") (fs-reject? 'link-exists?))
|
|
(err/rt-test (path->complete-path "tmp1") (fs-reject? 'path->complete-path))
|
|
(err/rt-test (filesystem-root-list) (fs-reject? 'filesystem-root-list))
|
|
(err/rt-test (find-system-path 'temp-dir) (fs-reject? 'find-system-path)))
|
|
|
|
;; Network - - - - - - - - - - - - - - - - - - - - - -
|
|
|
|
(define (net-reject? who host port what)
|
|
(lambda (x) (and (pair? x)
|
|
(eq? (car x) 'net-reject)
|
|
(eq? (cadr x) who)
|
|
(equal? (caddr x) host)
|
|
(equal? (cadddr x) port)
|
|
(eq? (cddddr x) what))))
|
|
|
|
(define early-udp (and (not (eq? 'macos (system-type)))
|
|
(udp-open-socket)))
|
|
|
|
(parameterize ([current-security-guard
|
|
(make-security-guard (current-security-guard)
|
|
void
|
|
(lambda (who host port mode)
|
|
(raise (list* 'net-reject who host port mode))))])
|
|
(err/rt-test (tcp-connect "other" 123) (net-reject? 'tcp-connect "other" 123 'client))
|
|
(err/rt-test (tcp-listen 123) (net-reject? 'tcp-listen #f 123 'server))
|
|
(unless (eq? 'macos (system-type)) ; no UDP in Mac OS Classic
|
|
(err/rt-test (udp-open-socket) (net-reject? 'udp-open-socket #f #f 'server))
|
|
(err/rt-test (udp-bind! early-udp "localhost" 40000) (net-reject? 'udp-bind! "localhost" 40000 'server))
|
|
(err/rt-test (udp-connect! early-udp "localhost" 40000) (net-reject? 'udp-connect! "localhost" 40000 'client))
|
|
(err/rt-test (udp-send-to early-udp "localhost" 40000 #"hi") (net-reject? 'udp-send-to "localhost" 40000 'client))))
|
|
|
|
(report-errs)
|