~ 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-string))89(include "test.scm")10(test-begin "ports")1112(define-syntax assert-error13 (syntax-rules ()14 ((_ expr)15 (assert (handle-exceptions _ #t expr #f)))))1617(define *text* #<<EOF18this is a test19<foof> #;33> (let ((in (open-input-string ""))) (close-input-port in)20 (read-char in)) [09:40]21<foof> Error: (read-char) port already closed: #<input port "(string)">22<foof> #;33> (let ((in (open-input-string ""))) (close-input-port in)23 (read-line in))24<foof> Error: call of non-procedure: #t25<foof> ... that's a little odd26<Bunny351> yuck. [09:44]27<Bunny351> double yuck. [10:00]28<sjamaan> yuck squared! [10:01]29<Bunny351> yuck powered by yuck30<Bunny351> (to the power of yuck, of course) [10:02]31<pbusser3> My yuck is bigger than yours!!!32<foof> yuck!33<foof> (that's a factorial)34<sjamaan> heh35<sjamaan> I think you outyucked us all [10:03]36<foof> well, for large enough values of yuck, yuck! ~= yuck^yuck [10:04]37ERC>38EOF39)4041(define p (open-input-string *text*))4243(assert (string=? "this is a test" (read-line p)))4445(assert46 (string=?47 "<foof> #;33> (let ((in (open-input-string \"\"))) (close-input-port in)"48 (read-line p)))49(assert (= 20 (length (read-lines (open-input-string *text*)))))5051(assert (char-ready? (open-input-string "")))5253(let ((out (open-output-string)))54 (test-equal "Initially, output string is empty"55 (get-output-string out) "")56 (display "foo" out)57 (test-equal "output can be extracted from output string"58 (get-output-string out) "foo")59 (close-output-port out)60 (test-equal "closing a string output port has no effect on the returned data"61 (get-output-string out) "foo")62 (test-error "writing to a closed string output port is an error"63 (display "bar" out)))6465;;; copy-port6667(assert68 (string=?69 *text*70 (with-output-to-string71 (lambda ()72 (copy-port (open-input-string *text*) (current-output-port)))))) ; read-char -> write-char7374(assert75 (equal?76 '(3 2 1)77 (let ((out '()))78 (copy-port ; read -> custom79 (open-input-string "1 2 3")80 #f81 read82 (lambda (x port) (set! out (cons x out))))83 out)))8485(assert86 (equal?87 "abc"88 (let ((out (open-output-string)))89 (copy-port ; read-char -> custom90 (open-input-string "abc")91 out92 read-char93 (lambda (x out) (write-char x out)))94 (get-output-string out))))9596(assert97 (equal?98 "abc"99 (let ((in (open-input-string "abc") )100 (out (open-output-string)))101 (copy-port ; custom -> write-char102 in out103 (lambda (in) (read-char in)))104 (get-output-string out))))105106;; {input,output}-port-open?107108(assert (input-port-open? (open-input-string "abc")))109(assert (output-port-open? (open-output-string)))110(assert-error (input-port-open? (open-output-string)))111(assert-error (output-port-open? (open-input-string "abc")))112113;; direction-specific port closure114115(let* ((n 0)116 (p (make-input-port (constantly #\a)117 (constantly #t)118 (lambda () (set! n (add1 n))))))119 (close-output-port p)120 (assert (input-port-open? p))121 (assert (= n 0))122 (close-input-port p)123 (assert (not (input-port-open? p)))124 (assert (= n 1))125 (close-input-port p)126 (assert (not (input-port-open? p)))127 (assert (= n 1)))128129(let* ((n 0)130 (p (make-output-port (lambda () (display #\a))131 (lambda () (set! n (add1 n))))))132 (close-input-port p)133 (assert (output-port-open? p))134 (assert (= n 0))135 (close-output-port p)136 (assert (not (output-port-open? p)))137 (assert (= n 1))138 (close-output-port p)139 (assert (not (output-port-open? p)))140 (assert (= n 1)))141142;; bidirectional ports143144(let* ((b (string))145 (w (lambda (s)146 (set! b (string-append b s))))147 (e (lambda ()148 (positive? (string-length b))))149 (r (lambda ()150 (let ((s b))151 (set! b (substring s 1))152 (string-ref s 0))))153 (i (make-input-port r e void))154 (o (make-output-port w void))155 (p (make-bidirectional-port i o)))156 (assert (input-port? p))157 (assert (output-port? p))158 (assert (input-port-open? p))159 (assert (output-port-open? p))160 (display "quartz ruby" p)161 (newline p)162 (assert (equal? (read p) 'quartz))163 (assert (equal? (read i) 'ruby))164 (display "emerald topaz" p)165 (newline p)166 (close-output-port p)167 (assert (not (output-port-open? o)))168 (assert (not (output-port-open? p)))169 (assert (equal? (read p) 'emerald))170 (assert (equal? (read i) 'topaz))171 (close-input-port p)172 (assert (not (input-port-open? i)))173 (assert (not (input-port-open? p))))174175;; fill buffers176(with-input-from-file "compiler.scm" read-string)177178(print "slow...")179(time180 (with-input-from-file "compiler.scm"181 (lambda ()182 (with-output-to-file "compiler.scm.2"183 (lambda ()184 (copy-port185 (current-input-port) (current-output-port)186 (lambda (port) (read-char port))187 (lambda (x port) (write-char x port))))))))188189(print "fast...")190(time191 (with-input-from-file "compiler.scm"192 (lambda ()193 (with-output-to-file "compiler.scm.2"194 (lambda ()195 (copy-port (current-input-port) (current-output-port)))))))196197(delete-file "compiler.scm.2")198199(define-syntax check200 (syntax-rules ()201 ((_ (expr-head expr-rest ...))202 (check 'expr-head (expr-head expr-rest ...)))203 ((_ name expr)204 (let ((okay (list 'okay)))205 (assert206 (eq? okay207 (condition-case208 (begin (print* name "...")209 (flush-output)210 (let ((output expr))211 (printf "FAIL [ ~S ]\n" output)))212 ((exn i/o file) (printf "OK\n") okay))))))))213214(cond-expand215 ((not mingw)216217 (define proc (process-fork (lambda () (tcp-accept (tcp-listen 8080)))))218219 (on-exit (lambda () (handle-exceptions exn #f (process-signal proc))))220221 (print "\n\nProcedures check on TCP ports being closed\n")222223 (receive (in out)224 (let lp ()225 (condition-case (tcp-connect "localhost" 8080)226 ((exn i/o net) (lp))))227 (close-output-port out)228 (close-input-port in)229 (check (tcp-addresses in))230 (check (tcp-port-numbers in))231 (check (tcp-abandon-port in))) ; Not sure about abandon-port232233234 ;; This tests for two bugs which occurred on NetBSD and possibly235 ;; other platforms, possibly due to multiprocessing:236 ;; read-line with EINTR would loop endlessly and process-wait would237 ;; signal a condition when interrupted rather than retrying.238 (set-signal-handler! signal/chld void) ; Should be a noop but triggers EINTR239 (receive (in out)240 (create-pipe)241 (receive (pid ok? status)242 (process-wait243 (process-fork244 (lambda ()245 (file-close in) ; close receiving end246 (with-output-to-port (open-output-file* out)247 (lambda ()248 (display "hello, world\n")249 ;; exit prevents buffers from being discarded by implicit _exit250 (exit 0))))))251 (file-close out) ; close sending end252 (assert (equal? '(#t 0 ("hello, world"))253 (list ok? status (read-lines (open-input-file* in)))))))254 )255 (else))256257(print "\n\nProcedures check on output ports being closed\n")258259(with-output-to-file "empty-file" void)260261(call-with-output-file "empty-file"262 (lambda (out)263 (close-output-port out)264 (check (write '(foo) out))265 (check (fprintf out "blabla"))266 (check "print-call-chain" (begin (print-call-chain out) (void)))267 (check (print-error-message (make-property-condition 'exn 'message "foo") out))268 (check "print" (with-output-to-port out269 (lambda () (print "foo"))))270 (check "print*" (with-output-to-port out271 (lambda () (print* "foo"))))272 (check (display "foo" out))273 (check (terminal-port? out)) ; Calls isatty() on C_SCHEME_FALSE?274 (check (newline out))275 (check (write-char #\x out))276 (check (write-line "foo" out))277 (check (write-bytevector '#u8(1 2 3) out))278 ;;(check (port->fileno in))279 (check (flush-output out))280281 (check (write-byte 120 out))282 (check (write-string "foo" out))))283284285(print "\n\nProcedures check on input ports being closed\n")286(call-with-input-file "empty-file"287 (lambda (in)288 (close-input-port in)289 (check (read in))290 (check (read-char in))291 (check (char-ready? in))292 (check (peek-char in))293 ;;(check (port->fileno in))294 (check (terminal-port? in)) ; Calls isatty() on C_SCHEME_FALSE?295 (check (read-line in 5))296 (check (read-bytevector 5 in))297 (check "read-bytevector!" (let ((dest (make-u8vector 5)))298 (read-bytevector! dest in 0 5)))299300 (check (read-byte in))301 (check (read-token (constantly #t) in))302 (check (read-string 10 in))303 (check "read-string!" (let ((buf (make-string 10)))304 (read-string! 10 buf in) buf))))305306(print "\nEmbedded NUL bytes in filenames are rejected\n")307(assert-error (with-output-to-file "embedded\x00;null-byte" void))308309;;; #978 -- port-position checks for read-line310311(define (read-line/pos p limit) ;; common312 (let ((s (read-line p limit)))313 (let-values (((row col) (port-position p)))314 (list s row col))))315316(define (read-string-line/pos str limit)317 (read-line/pos (open-input-string str) limit))318319(define (read-process-line/pos cmd args limit)320 (let-values (((i o pid) (process cmd args)))321 (let ((rc (read-line/pos i limit)))322 (close-input-port i)323 (close-output-port o)324 rc)))325(define (read-echo-line/pos str limit)326 (read-process-line/pos "echo" (list "-n" str) limit))327328(define (test-port-position proc)329 (test-equal "advance row when encountering delim"330 (proc "abcde\nfghi" 6)331 '("abcde" 2 0))332 (test-equal "reaching limit sets col to limit, and does not advance row"333 (proc "abcdefghi" 6)334 '("abcdef" 1 6))335 (test-equal "delimiter counted in limit" ;; observed behavior, strange336 (proc "abcdef\nghi" 6)337 '("abcdef" 1 6))338 (test-equal "EOF reached"339 (proc "abcde" 6)340 '("abcde" 1 5)))341342(test-group343 "read-line string port position tests"344 (test-port-position read-string-line/pos))345346(test-group "read-string!"347 (let ((in (open-input-string "1234567890"))348 (buf (make-string 5)))349 (test-equal "peek-char won't influence the result of read-string!"350 (peek-char in)351 #\1)352 (test-equal "read-string! won't read past buffer if given #f"353 (read-string! #f buf in)354 5)355 (test-equal "read-string! reads the requested bytes with #f"356 buf357 "12345")358 (test-equal "read-string! won't read past buffer if given #f and offset"359 (read-string! #f buf in 3)360 2)361 (test-equal "read-string! reads the requested bytes with #f and offset"362 buf363 "12367")364 (test-equal "read-string! reads until the end correctly"365 (read-string! #f buf in)366 3)367 (test-equal "read-string! leaves the buffer's tail intact"368 buf369 "89067")370 (test-equal "after peek-char at EOF, read-string! doesn't mutate the buffer"371 (begin (peek-char in)372 (read-string! #f buf in)373 buf)374 "89067"))375 (let ((in (open-input-string "1234567890"))376 (buf (make-string 5)))377 (test-equal "read-string! won't read past buffer if given size"378 (read-string! 10 buf in)379 5)380 (test-equal "read-string! reads the requested bytes with buffer size"381 buf382 "12345")383 (test-equal "read-string! won't read past buffer if given size and offset"384 (read-string! 10 buf in 3)385 2)386 (test-equal "read-string! reads the requested bytes with buffer size and offset"387 buf388 "12367")389 (test-equal "read-string! reads until the end correctly with buffer size"390 (read-string! 10 buf in)391 3)392 (test-equal "read-string! leaves the buffer's tail intact"393 buf394 "89067")395 (test-equal "read-string! at EOF reads nothing"396 (read-string! 10 buf in)397 0)398 (test-equal "read-string! at EOF doesn't mutate the buffer"399 buf400 "89067")))401402(test-group "line endings"403 (let ((s "foo\nbar\rbaz\r\nqux")404 (f (lambda ()405 (test-equal "\\n" (read-line) "foo")406 (test-equal "\\r" (read-line) "bar")407 (test-equal "\\r\\n" (read-line) "baz")408 (test-equal "eof" (read-line) "qux"))))409 (test-group "string port"410 (with-input-from-string s f))411 (test-group "file port"412 (let ((file "mixed-line-endings"))413 (with-output-to-file file (lambda () (display s)))414 (with-input-from-file file f)415 (delete-file* file)))416 (test-group "custom port"417 (let* ((p (open-input-string s))418 (p* (make-input-port (lambda () (read-char p))419 (lambda () (char-ready? p))420 (lambda () (close-input-port p)))))421 (with-input-from-port p* f)))))422423;; Disabled because it requires `echo -n` for424;; the EOF test, and that is not available on all systems.425;; Uncomment locally to run.426#;427(test-group428 "read-line process port position tests"429 (test-port-position read-echo-line/pos))430431;; bytevector I/O, moved here from srf-4-tests.scm:432;; Ticket #1124: read-u8vector! w/o length, dest smaller than source.433(test-group434 "bytevector I/O"435(let ((input (open-input-string "abcdefghijklmnopqrstuvwxyz"))436 (u8vec (make-bytevector 10)))437 (assert (= 10 (read-bytevector! u8vec input)))438 (assert (equal? u8vec #u8(97 98 99 100 101 102 103 104 105 106)))439 (assert (= 5 (read-bytevector! u8vec input 5)))440 (assert (equal? u8vec #u8(97 98 99 100 101 107 108 109 110 111)))441 (assert (= 5 (read-bytevector! u8vec input 0 5)))442 (assert (equal? u8vec #u8(112 113 114 115 116 107 108 109 110 111)))443 (assert (= 6 (read-bytevector! u8vec input 0 10)))444 (assert (equal? u8vec #u8(117 118 119 120 121 122 108 109 110 111))))445446(let ((input (open-input-string "abcdefghijklmnopqrs")))447 (assert (equal? (read-bytevector 5 input)448 #u8(97 98 99 100 101)))449 (assert (equal? (read-bytevector 5 input) #u8(102 103 104 105 106)))450 (assert (equal? (read-bytevector #f input)451 #u8(107 108 109 110 111 112 113 114 115)))452 (with-input-from-string "abcdefghijklmnopqrs"453 (lambda ()454 (assert (equal? (read-bytevector 5)455 #u8(97 98 99 100 101)))456 (assert (equal? (read-bytevector 5) #u8(102 103 104 105 106)))457 (assert (equal? (read-bytevector)458 #u8(107 108 109 110 111 112 113 114 115))))))459460(assert (string=?461 "abc"462 (with-output-to-string463 (lambda ()464 (write-bytevector #u8(97 98 99))))))465466(assert (string=?467 "bc"468 (with-output-to-string469 (lambda ()470 (write-bytevector #u8(97 98 99) (current-output-port) 1)))))471472(assert (string=?473 "a"474 (with-output-to-string475 (lambda ()476 (write-bytevector #u8(97 98 99) (current-output-port) 0 1)))))477478(assert (string=?479 "b"480 (with-output-to-string481 (lambda ()482 (write-bytevector #u8(97 98 99) (current-output-port) 1 2)))))483484(assert (string=?485 ""486 (with-output-to-string487 (lambda ()488 (write-bytevector #u8())))))489)490491;;;492493(test-end)494495(test-exit)