~ 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;; TODO: include the other documented keyword arguments:348;; #:peek-u8 #:peek-char and #:read-line349(test-group "make[-binary]-input-port callbacks"350 (let ()351352 (define (test-sequence in)353 (test-equal "read-char" (read-char in) #\1)354 (test-equal "read-string" (read-string 2 in) "23")355 (test-equal "read-char again" (read-char in) #\4)356 (test-equal "read-bytevector" (read-bytevector 2 in) #u8("56"))357 (test-equal "read-string " (read-string 2 in) "78")358 (test-equal "read-string" (read-string #f in) "90"))359360 (test-group "make-input-port read sequences"361 (test-sequence362 (let* ((p (open-input-string "1234567890")))363 (make-input-port364 (lambda () (read-char p))365 (lambda () (char-ready? p))366 (lambda () (close-input-port p))367 #:peek-u8 #f368 #:read-bytevector369 (lambda (bv start end)370 (read-bytevector! bv p start end))))))371372 (test-group "make-binary-input-port read sequences"373 (test-sequence374 (let* ((p (open-input-string "1234567890")))375 (make-binary-input-port376 (lambda () (read-u8 p))377 (lambda () (char-ready? p))378 (lambda () (close-input-port p))379 #:peek-u8 #f380 #:read-bytevector381 (lambda (bv start end)382 (read-bytevector! bv p start end))))))))383384(test-group "read-string!"385 (let ((in (open-input-string "1234567890"))386 (buf (make-string 5)))387 (test-equal "peek-char won't influence the result of read-string!"388 (peek-char in)389 #\1)390 (test-equal "read-string! won't read past buffer if given #f"391 (read-string! #f buf in)392 5)393 (test-equal "read-string! reads the requested bytes with #f"394 buf395 "12345")396 (test-equal "read-string! won't read past buffer if given #f and offset"397 (read-string! #f buf in 3)398 2)399 (test-equal "read-string! reads the requested bytes with #f and offset"400 buf401 "12367")402 (test-equal "read-string! reads until the end correctly"403 (read-string! #f buf in)404 3)405 (test-equal "read-string! leaves the buffer's tail intact"406 buf407 "89067")408 (test-equal "after peek-char at EOF, read-string! doesn't mutate the buffer"409 (begin (peek-char in)410 (read-string! #f buf in)411 buf)412 "89067"))413 (let ((in (open-input-string "1234567890"))414 (buf (make-string 5)))415 (test-equal "read-string! won't read past buffer if given size"416 (read-string! 10 buf in)417 5)418 (test-equal "read-string! reads the requested bytes with buffer size"419 buf420 "12345")421 (test-equal "read-string! won't read past buffer if given size and offset"422 (read-string! 10 buf in 3)423 2)424 (test-equal "read-string! reads the requested bytes with buffer size and offset"425 buf426 "12367")427 (test-equal "read-string! reads until the end correctly with buffer size"428 (read-string! 10 buf in)429 3)430 (test-equal "read-string! leaves the buffer's tail intact"431 buf432 "89067")433 (test-equal "read-string! at EOF reads nothing"434 (read-string! 10 buf in)435 0)436 (test-equal "read-string! at EOF doesn't mutate the buffer"437 buf438 "89067")))439440(test-group "line endings"441 (let ((s "foo\nbar\rbaz\r\nqux")442 (f (lambda ()443 (test-equal "\\n" (read-line) "foo")444 (test-equal "\\r" (read-line) "bar")445 (test-equal "\\r\\n" (read-line) "baz")446 (test-equal "eof" (read-line) "qux"))))447 (test-group "string port"448 (with-input-from-string s f))449 (test-group "file port"450 (let ((file "mixed-line-endings"))451 (with-output-to-file file (lambda () (display s)))452 (with-input-from-file file f)453 (delete-file* file)))454 (test-group "custom port"455 (let* ((p (open-input-string s))456 (p* (make-input-port (lambda () (read-char p))457 (lambda () (char-ready? p))458 (lambda () (close-input-port p)))))459 (with-input-from-port p* f)))))460461;; Disabled because it requires `echo -n` for462;; the EOF test, and that is not available on all systems.463;; Uncomment locally to run.464#;465(test-group466 "read-line process port position tests"467 (test-port-position read-echo-line/pos))468469;; binary custom ports470471(define count 1)472(define open #t)473474(define (rdb)475 (let ((c count))476 (cond ((> c 5) #!eof)477 (else478 (set! count (+ count 1))479 c))))480481(define (brdy?) #t)482(define (cls) (set! open #f))483484(define (rbv bv from to)485 (let loop ((i from))486 (if (>= i to)487 (- i from)488 (let ((b (rdb)))489 (if (eof-object? b)490 (- i from)491 (begin492 (u8vector-set! bv i b)493 (loop (+ i 1))))))))494495(define (pkb) count)496497(define written '())498499(define (wrb b)500 (set! written (append written (list b))))501502(define (wrbv bv from to)503 (do ((i from (+ i 1)))504 ((>= i to) (- from to))505 (wrb (u8vector-ref bv i))))506507(define p1 (make-binary-input-port rdb brdy? cls))508509(assert (u8-ready? p1))510(assert (= (read-u8 p1) 1))511(assert (= (peek-u8 p1) 2))512(assert (= (read-u8 p1) 2))513(assert (equal? (read-bytevector 4 p1) '#u8(3 4 5)))514(assert (eof-object? (read-u8 p1)))515(close-output-port p1)516517(set! count 1)518(define p2 (make-binary-input-port rdb brdy? cls peek-u8: pkb read-bytevector: rbv))519520(assert (u8-ready? p2))521(assert (= (read-u8 p2) 1))522(assert (= (peek-u8 p2) 2))523(assert (= (read-u8 p2) 2))524(assert (equal? (read-bytevector 4 p2) '#u8(3 4 5)))525(assert (eof-object? (read-u8 p2)))526(close-output-port p2)527528(define p3 (make-binary-output-port wrb cls))529(write-u8 99 p3)530(write-bytevector '#u8(10 11 12) p3)531(close-output-port p3)532(assert (equal? written '(99 10 11 12)))533534(set! written '())535(define p4 (make-binary-output-port wrb cls force-output: void write-bytevector: wrbv))536(write-u8 99 p4)537(write-bytevector '#u8(10 11 12) p4)538(flush-output-port p4)539(close-output-port p4)540(assert (equal? written '(99 10 11 12)))541542;; bytevector I/O, moved here from srf-4-tests.scm:543;; Ticket #1124: read-u8vector! w/o length, dest smaller than source.544(test-group545 "bytevector I/O"546(let ((input (open-input-string "abcdefghijklmnopqrstuvwxyz"))547 (u8vec (make-bytevector 10)))548 (assert (= 10 (read-bytevector! u8vec input)))549 (assert (equal? u8vec #u8(97 98 99 100 101 102 103 104 105 106)))550 (assert (= 5 (read-bytevector! u8vec input 5)))551 (assert (equal? u8vec #u8(97 98 99 100 101 107 108 109 110 111)))552 (assert (= 5 (read-bytevector! u8vec input 0 5)))553 (assert (equal? u8vec #u8(112 113 114 115 116 107 108 109 110 111)))554 (assert (= 6 (read-bytevector! u8vec input 0 10)))555 (assert (equal? u8vec #u8(117 118 119 120 121 122 108 109 110 111))))556557(let ((input (open-input-string "abcdefghijklmnopqrs")))558 (assert (equal? (read-bytevector 5 input)559 #u8(97 98 99 100 101)))560 (assert (equal? (read-bytevector 5 input) #u8(102 103 104 105 106)))561 (assert (equal? (read-bytevector #f input)562 #u8(107 108 109 110 111 112 113 114 115)))563 (with-input-from-string "abcdefghijklmnopqrs"564 (lambda ()565 (assert (equal? (read-bytevector 5)566 #u8(97 98 99 100 101)))567 (assert (equal? (read-bytevector 5) #u8(102 103 104 105 106)))568 (assert (equal? (read-bytevector)569 #u8(107 108 109 110 111 112 113 114 115))))))570571(assert (string=?572 "abc"573 (with-output-to-string574 (lambda ()575 (write-bytevector #u8(97 98 99))))))576577(assert (string=?578 "bc"579 (with-output-to-string580 (lambda ()581 (write-bytevector #u8(97 98 99) (current-output-port) 1)))))582583(assert (string=?584 "a"585 (with-output-to-string586 (lambda ()587 (write-bytevector #u8(97 98 99) (current-output-port) 0 1)))))588589(assert (string=?590 "b"591 (with-output-to-string592 (lambda ()593 (write-bytevector #u8(97 98 99) (current-output-port) 1 2)))))594595(assert (string=?596 ""597 (with-output-to-string598 (lambda ()599 (write-bytevector #u8())))))600)601602;;;603604(test-end)605606(test-exit)