~ chicken-core (master) /tests/port-tests.scm
Trap1(import chicken.condition chicken.file chicken.file.posix2 chicken.flonum chicken.format chicken.io chicken.port3 chicken.bytevector4 chicken.process chicken.process.signal chicken.tcp chicken.number-vector)56(import (only (scheme base) input-port-open? output-port-open? open-input-string7 write-string open-output-string get-output-string8 flush-output-port peek-u8 u8-ready? read-u8 write-u8))910(include "test.scm")11(test-begin "ports")1213(define-syntax assert-error14 (syntax-rules ()15 ((_ expr)16 (assert (handle-exceptions _ #t expr #f)))))1718(define *text* #<<EOF19this is a test20<foof> #;33> (let ((in (open-input-string ""))) (close-input-port in)21 (read-char in)) [09:40]22<foof> Error: (read-char) port already closed: #<input port "(string)">23<foof> #;33> (let ((in (open-input-string ""))) (close-input-port in)24 (read-line in))25<foof> Error: call of non-procedure: #t26<foof> ... that's a little odd27<Bunny351> yuck. [09:44]28<Bunny351> double yuck. [10:00]29<sjamaan> yuck squared! [10:01]30<Bunny351> yuck powered by yuck31<Bunny351> (to the power of yuck, of course) [10:02]32<pbusser3> My yuck is bigger than yours!!!33<foof> yuck!34<foof> (that's a factorial)35<sjamaan> heh36<sjamaan> I think you outyucked us all [10:03]37<foof> well, for large enough values of yuck, yuck! ~= yuck^yuck [10:04]38ERC>39EOF40)4142(define p (open-input-string *text*))4344(assert (string=? "this is a test" (read-line p)))4546(assert47 (string=?48 "<foof> #;33> (let ((in (open-input-string \"\"))) (close-input-port in)"49 (read-line p)))50(assert (= 20 (length (read-lines (open-input-string *text*)))))5152(assert (char-ready? (open-input-string "")))5354(let ((out (open-output-string)))55 (test-equal "Initially, output string is empty"56 (get-output-string out) "")57 (display "foo" out)58 (test-equal "output can be extracted from output string"59 (get-output-string out) "foo")60 (close-output-port out)61 (test-equal "closing a string output port has no effect on the returned data"62 (get-output-string out) "foo")63 (test-error "writing to a closed string output port is an error"64 (display "bar" out)))6566;;; copy-port6768(assert69 (string=?70 *text*71 (with-output-to-string72 (lambda ()73 (copy-port (open-input-string *text*) (current-output-port)))))) ; read-char -> write-char7475(assert76 (equal?77 '(3 2 1)78 (let ((out '()))79 (copy-port ; read -> custom80 (open-input-string "1 2 3")81 #f82 read83 (lambda (x port) (set! out (cons x out))))84 out)))8586(assert87 (equal?88 "abc"89 (let ((out (open-output-string)))90 (copy-port ; read-char -> custom91 (open-input-string "abc")92 out93 read-char94 (lambda (x out) (write-char x out)))95 (get-output-string out))))9697(assert98 (equal?99 "abc"100 (let ((in (open-input-string "abc") )101 (out (open-output-string)))102 (copy-port ; custom -> write-char103 in out104 (lambda (in) (read-char in)))105 (get-output-string out))))106107;; {input,output}-port-open?108109(assert (input-port-open? (open-input-string "abc")))110(assert (output-port-open? (open-output-string)))111(assert-error (input-port-open? (open-output-string)))112(assert-error (output-port-open? (open-input-string "abc")))113114;; direction-specific port closure115116(let* ((n 0)117 (p (make-input-port (constantly #\a)118 (constantly #t)119 (lambda () (set! n (add1 n))))))120 (close-output-port p)121 (assert (input-port-open? p))122 (assert (= n 0))123 (close-input-port p)124 (assert (not (input-port-open? p)))125 (assert (= n 1))126 (close-input-port p)127 (assert (not (input-port-open? p)))128 (assert (= n 1)))129130(let* ((n 0)131 (p (make-output-port (lambda () (display #\a))132 (lambda () (set! n (add1 n))))))133 (close-input-port p)134 (assert (output-port-open? p))135 (assert (= n 0))136 (close-output-port p)137 (assert (not (output-port-open? p)))138 (assert (= n 1))139 (close-output-port p)140 (assert (not (output-port-open? p)))141 (assert (= n 1)))142143;; bidirectional ports144145(let* ((b (string))146 (w (lambda (s)147 (set! b (string-append b s))))148 (e (lambda ()149 (positive? (string-length b))))150 (r (lambda ()151 (let ((s b))152 (set! b (substring s 1))153 (string-ref s 0))))154 (i (make-input-port r e void))155 (o (make-output-port w void))156 (p (make-bidirectional-port i o)))157 (assert (input-port? p))158 (assert (output-port? p))159 (assert (input-port-open? p))160 (assert (output-port-open? p))161 (display "quartz ruby" p)162 (newline p)163 (assert (equal? (read p) 'quartz))164 (assert (equal? (read i) 'ruby))165 (display "emerald topaz" p)166 (newline p)167 (close-output-port p)168 (assert (not (output-port-open? o)))169 (assert (not (output-port-open? p)))170 (assert (equal? (read p) 'emerald))171 (assert (equal? (read i) 'topaz))172 (close-input-port p)173 (assert (not (input-port-open? i)))174 (assert (not (input-port-open? p))))175176;; fill buffers177(with-input-from-file "compiler.scm" read-string)178179(print "slow...")180(time181 (with-input-from-file "compiler.scm"182 (lambda ()183 (with-output-to-file "compiler.scm.2"184 (lambda ()185 (copy-port186 (current-input-port) (current-output-port)187 (lambda (port) (read-char port))188 (lambda (x port) (write-char x port))))))))189190(print "fast...")191(time192 (with-input-from-file "compiler.scm"193 (lambda ()194 (with-output-to-file "compiler.scm.2"195 (lambda ()196 (copy-port (current-input-port) (current-output-port)))))))197198(delete-file "compiler.scm.2")199200(define-syntax check201 (syntax-rules ()202 ((_ (expr-head expr-rest ...))203 (check 'expr-head (expr-head expr-rest ...)))204 ((_ name expr)205 (let ((okay (list 'okay)))206 (assert207 (eq? okay208 (condition-case209 (begin (print* name "...")210 (flush-output)211 (let ((output expr))212 (printf "FAIL [ ~S ]\n" output)))213 ((exn i/o file) (printf "OK\n") okay))))))))214215(cond-expand216 ((not windows)217218 (define proc (process-fork (lambda () (tcp-accept (tcp-listen 8080)))))219220 (on-exit (lambda () (handle-exceptions exn #f (process-signal proc))))221222 (print "\n\nProcedures check on TCP ports being closed\n")223224 (receive (in out)225 (let lp ()226 (condition-case (tcp-connect "localhost" 8080)227 ((exn i/o net) (lp))))228 (close-output-port out)229 (close-input-port in)230 (check (tcp-addresses in))231 (check (tcp-port-numbers in))232 (check (tcp-abandon-port in))) ; Not sure about abandon-port233234235 ;; This tests for two bugs which occurred on NetBSD and possibly236 ;; other platforms, possibly due to multiprocessing:237 ;; read-line with EINTR would loop endlessly and process-wait would238 ;; signal a condition when interrupted rather than retrying.239 (set-signal-handler! signal/chld void) ; Should be a noop but triggers EINTR240 (receive (in out)241 (create-pipe)242 (receive (pid ok? status)243 (process-wait244 (process-fork245 (lambda ()246 (file-close in) ; close receiving end247 (with-output-to-port (open-output-file* out)248 (lambda ()249 (display "hello, world\n")250 ;; exit prevents buffers from being discarded by implicit _exit251 (exit 0))))))252 (file-close out) ; close sending end253 (assert (equal? '(#t 0 ("hello, world"))254 (list ok? status (read-lines (open-input-file* in)))))))255 )256 (else))257258(print "\n\nProcedures check on output ports being closed\n")259260(with-output-to-file "empty-file" void)261262(call-with-output-file "empty-file"263 (lambda (out)264 (close-output-port out)265 (check (write '(foo) out))266 (check (fprintf out "blabla"))267 (check "print-call-chain" (begin (print-call-chain out) (void)))268 (check (print-error-message (make-property-condition 'exn 'message "foo") out))269 (check "print" (with-output-to-port out270 (lambda () (print "foo"))))271 (check "print*" (with-output-to-port out272 (lambda () (print* "foo"))))273 (check (display "foo" out))274 (check (terminal-port? out)) ; Calls isatty() on C_SCHEME_FALSE?275 (check (newline out))276 (check (write-char #\x out))277 (check (write-line "foo" out))278 (check (write-bytevector '#u8(1 2 3) out))279 ;;(check (port->fileno in))280 (check (flush-output out))281282 (check (write-byte 120 out))283 (check (write-string "foo" out))))284285286(print "\n\nProcedures check on input ports being closed\n")287(call-with-input-file "empty-file"288 (lambda (in)289 (close-input-port in)290 (check (read in))291 (check (read-char in))292 (check (char-ready? in))293 (check (peek-char in))294 ;;(check (port->fileno in))295 (check (terminal-port? in)) ; Calls isatty() on C_SCHEME_FALSE?296 (check (read-line in 5))297 (check (read-bytevector 5 in))298 (check "read-bytevector!" (let ((dest (make-u8vector 5)))299 (read-bytevector! dest in 0 5)))300301 (check (read-byte in))302 (check (read-token (constantly #t) in))303 (check (read-string 10 in))304 (check "read-string!" (let ((buf (make-string 10)))305 (read-string! 10 buf in) buf))))306307(print "\nEmbedded NUL bytes in filenames are rejected\n")308(assert-error (with-output-to-file "embedded\x00;null-byte" void))309310;;; #978 -- port-position checks for read-line311312(define (read-line/pos p limit) ;; common313 (let ((s (read-line p limit)))314 (let-values (((row col) (port-position p)))315 (list s row col))))316317(define (read-string-line/pos str limit)318 (read-line/pos (open-input-string str) limit))319320(define (read-process-line/pos cmd args limit)321 (let-values (((i o pid) (process cmd args)))322 (let ((rc (read-line/pos i limit)))323 (close-input-port i)324 (close-output-port o)325 rc)))326(define (read-echo-line/pos str limit)327 (read-process-line/pos "echo" (list "-n" str) limit))328329(define (test-port-position proc)330 (test-equal "advance row when encountering delim"331 (proc "abcde\nfghi" 6)332 '("abcde" 2 0))333 (test-equal "reaching limit sets col to limit, and does not advance row"334 (proc "abcdefghi" 6)335 '("abcdef" 1 6))336 (test-equal "delimiter counted in limit" ;; observed behavior, strange337 (proc "abcdef\nghi" 6)338 '("abcdef" 1 6))339 (test-equal "EOF reached"340 (proc "abcde" 6)341 '("abcde" 1 5)))342343(test-group344 "read-line string port position tests"345 (test-port-position read-string-line/pos))346347(test-group "read-string!"348 (let ((in (open-input-string "1234567890"))349 (buf (make-string 5)))350 (test-equal "peek-char won't influence the result of read-string!"351 (peek-char in)352 #\1)353 (test-equal "read-string! won't read past buffer if given #f"354 (read-string! #f buf in)355 5)356 (test-equal "read-string! reads the requested bytes with #f"357 buf358 "12345")359 (test-equal "read-string! won't read past buffer if given #f and offset"360 (read-string! #f buf in 3)361 2)362 (test-equal "read-string! reads the requested bytes with #f and offset"363 buf364 "12367")365 (test-equal "read-string! reads until the end correctly"366 (read-string! #f buf in)367 3)368 (test-equal "read-string! leaves the buffer's tail intact"369 buf370 "89067")371 (test-equal "after peek-char at EOF, read-string! doesn't mutate the buffer"372 (begin (peek-char in)373 (read-string! #f buf in)374 buf)375 "89067"))376 (let ((in (open-input-string "1234567890"))377 (buf (make-string 5)))378 (test-equal "read-string! won't read past buffer if given size"379 (read-string! 10 buf in)380 5)381 (test-equal "read-string! reads the requested bytes with buffer size"382 buf383 "12345")384 (test-equal "read-string! won't read past buffer if given size and offset"385 (read-string! 10 buf in 3)386 2)387 (test-equal "read-string! reads the requested bytes with buffer size and offset"388 buf389 "12367")390 (test-equal "read-string! reads until the end correctly with buffer size"391 (read-string! 10 buf in)392 3)393 (test-equal "read-string! leaves the buffer's tail intact"394 buf395 "89067")396 (test-equal "read-string! at EOF reads nothing"397 (read-string! 10 buf in)398 0)399 (test-equal "read-string! at EOF doesn't mutate the buffer"400 buf401 "89067")))402403(test-group "line endings"404 (let ((s "foo\nbar\rbaz\r\nqux")405 (f (lambda ()406 (test-equal "\\n" (read-line) "foo")407 (test-equal "\\r" (read-line) "bar")408 (test-equal "\\r\\n" (read-line) "baz")409 (test-equal "eof" (read-line) "qux"))))410 (test-group "string port"411 (with-input-from-string s f))412 (test-group "file port"413 (let ((file "mixed-line-endings"))414 (with-output-to-file file (lambda () (display s)))415 (with-input-from-file file f)416 (delete-file* file)))417 (test-group "custom port"418 (let* ((p (open-input-string s))419 (p* (make-input-port (lambda () (read-char p))420 (lambda () (char-ready? p))421 (lambda () (close-input-port p)))))422 (with-input-from-port p* f)))))423424;; Disabled because it requires `echo -n` for425;; the EOF test, and that is not available on all systems.426;; Uncomment locally to run.427#;428(test-group429 "read-line process port position tests"430 (test-port-position read-echo-line/pos))431432;; binary custom ports433434(define count 1)435(define open #t)436437(define (rdb)438 (let ((c count))439 (cond ((> c 5) #!eof)440 (else441 (set! count (+ count 1))442 c))))443444(define (brdy?) #t)445(define (cls) (set! open #f))446447(define (rbv bv from to)448 (let loop ((i from))449 (if (>= i to)450 (- i from)451 (let ((b (rdb)))452 (if (eof-object? b)453 (- i from)454 (begin455 (u8vector-set! bv i b)456 (loop (+ i 1))))))))457458(define (pkb) count)459460(define written '())461462(define (wrb b)463 (set! written (append written (list b))))464465(define (wrbv bv from to)466 (do ((i from (+ i 1)))467 ((>= i to) (- from to))468 (wrb (u8vector-ref bv i))))469470(define p1 (make-binary-input-port rdb brdy? cls))471472(assert (u8-ready? p1))473(assert (= (read-u8 p1) 1))474(assert (= (peek-u8 p1) 2))475(assert (= (read-u8 p1) 2))476(assert (equal? (read-bytevector 4 p1) '#u8(3 4 5)))477(assert (eof-object? (read-u8 p1)))478(close-output-port p1)479480(set! count 1)481(define p2 (make-binary-input-port rdb brdy? cls peek-u8: pkb read-bytevector: rbv))482483(assert (u8-ready? p2))484(assert (= (read-u8 p2) 1))485(assert (= (peek-u8 p2) 2))486(assert (= (read-u8 p2) 2))487(assert (equal? (read-bytevector 4 p2) '#u8(3 4 5)))488(assert (eof-object? (read-u8 p2)))489(close-output-port p2)490491(define p3 (make-binary-output-port wrb cls))492(write-u8 99 p3)493(write-bytevector '#u8(10 11 12) p3)494(close-output-port p3)495(assert (equal? written '(99 10 11 12)))496497(set! written '())498(define p4 (make-binary-output-port wrb cls force-output: void write-bytevector: wrbv))499(write-u8 99 p4)500(write-bytevector '#u8(10 11 12) p4)501(flush-output-port p4)502(close-output-port p4)503(assert (equal? written '(99 10 11 12)))504505;; bytevector I/O, moved here from srf-4-tests.scm:506;; Ticket #1124: read-u8vector! w/o length, dest smaller than source.507(test-group508 "bytevector I/O"509(let ((input (open-input-string "abcdefghijklmnopqrstuvwxyz"))510 (u8vec (make-bytevector 10)))511 (assert (= 10 (read-bytevector! u8vec input)))512 (assert (equal? u8vec #u8(97 98 99 100 101 102 103 104 105 106)))513 (assert (= 5 (read-bytevector! u8vec input 5)))514 (assert (equal? u8vec #u8(97 98 99 100 101 107 108 109 110 111)))515 (assert (= 5 (read-bytevector! u8vec input 0 5)))516 (assert (equal? u8vec #u8(112 113 114 115 116 107 108 109 110 111)))517 (assert (= 6 (read-bytevector! u8vec input 0 10)))518 (assert (equal? u8vec #u8(117 118 119 120 121 122 108 109 110 111))))519520(let ((input (open-input-string "abcdefghijklmnopqrs")))521 (assert (equal? (read-bytevector 5 input)522 #u8(97 98 99 100 101)))523 (assert (equal? (read-bytevector 5 input) #u8(102 103 104 105 106)))524 (assert (equal? (read-bytevector #f input)525 #u8(107 108 109 110 111 112 113 114 115)))526 (with-input-from-string "abcdefghijklmnopqrs"527 (lambda ()528 (assert (equal? (read-bytevector 5)529 #u8(97 98 99 100 101)))530 (assert (equal? (read-bytevector 5) #u8(102 103 104 105 106)))531 (assert (equal? (read-bytevector)532 #u8(107 108 109 110 111 112 113 114 115))))))533534(assert (string=?535 "abc"536 (with-output-to-string537 (lambda ()538 (write-bytevector #u8(97 98 99))))))539540(assert (string=?541 "bc"542 (with-output-to-string543 (lambda ()544 (write-bytevector #u8(97 98 99) (current-output-port) 1)))))545546(assert (string=?547 "a"548 (with-output-to-string549 (lambda ()550 (write-bytevector #u8(97 98 99) (current-output-port) 0 1)))))551552(assert (string=?553 "b"554 (with-output-to-string555 (lambda ()556 (write-bytevector #u8(97 98 99) (current-output-port) 1 2)))))557558(assert (string=?559 ""560 (with-output-to-string561 (lambda ()562 (write-bytevector #u8())))))563)564565;;;566567(test-end)568569(test-exit)