~ chicken-core (chicken-5) /tests/port-tests.scm
Trap1(import chicken.condition chicken.file chicken.file.posix2 chicken.flonum chicken.format chicken.io chicken.port3 chicken.process chicken.process.signal chicken.tcp srfi-4)45(include "test.scm")6(test-begin "ports")78(define-syntax assert-error9 (syntax-rules ()10 ((_ expr)11 (assert (handle-exceptions _ #t expr #f)))))1213(define *text* #<<EOF14this is a test15<foof> #;33> (let ((in (open-input-string ""))) (close-input-port in)16 (read-char in)) [09:40]17<foof> Error: (read-char) port already closed: #<input port "(string)">18<foof> #;33> (let ((in (open-input-string ""))) (close-input-port in)19 (read-line in))20<foof> Error: call of non-procedure: #t21<foof> ... that's a little odd22<Bunny351> yuck. [09:44]23<Bunny351> double yuck. [10:00]24<sjamaan> yuck squared! [10:01]25<Bunny351> yuck powered by yuck26<Bunny351> (to the power of yuck, of course) [10:02]27<pbusser3> My yuck is bigger than yours!!!28<foof> yuck!29<foof> (that's a factorial)30<sjamaan> heh31<sjamaan> I think you outyucked us all [10:03]32<foof> well, for large enough values of yuck, yuck! ~= yuck^yuck [10:04]33ERC>34EOF35)3637(define p (open-input-string *text*))3839(assert (string=? "this is a test" (read-line p)))4041(assert42 (string=?43 "<foof> #;33> (let ((in (open-input-string \"\"))) (close-input-port in)"44 (read-line p)))45(assert (= 20 (length (read-lines (open-input-string *text*)))))4647(assert (char-ready? (open-input-string "")))4849(let ((out (open-output-string)))50 (test-equal "Initially, output string is empty"51 (get-output-string out) "")52 (display "foo" out)53 (test-equal "output can be extracted from output string"54 (get-output-string out) "foo")55 (close-output-port out)56 (test-equal "closing a string output port has no effect on the returned data"57 (get-output-string out) "foo")58 (test-error "writing to a closed string output port is an error"59 (display "bar" out)))6061;;; copy-port6263(assert64 (string=?65 *text*66 (with-output-to-string67 (lambda ()68 (copy-port (open-input-string *text*) (current-output-port)))))) ; read-char -> write-char6970(assert71 (equal?72 '(3 2 1)73 (let ((out '()))74 (copy-port ; read -> custom75 (open-input-string "1 2 3")76 #f77 read78 (lambda (x port) (set! out (cons x out))))79 out)))8081(assert82 (equal?83 "abc"84 (let ((out (open-output-string)))85 (copy-port ; read-char -> custom86 (open-input-string "abc")87 out88 read-char89 (lambda (x out) (write-char x out)))90 (get-output-string out))))9192(assert93 (equal?94 "abc"95 (let ((in (open-input-string "abc") )96 (out (open-output-string)))97 (copy-port ; custom -> write-char98 in out99 (lambda (in) (read-char in)))100 (get-output-string out))))101102;; {input,output}-port-open?103104(assert (input-port-open? (open-input-string "abc")))105(assert (output-port-open? (open-output-string)))106(assert-error (input-port-open? (open-output-string)))107(assert-error (output-port-open? (open-input-string "abc")))108109;; direction-specific port closure110111(let* ((n 0)112 (p (make-input-port (constantly #\a)113 (constantly #t)114 (lambda () (set! n (add1 n))))))115 (close-output-port p)116 (assert (input-port-open? p))117 (assert (= n 0))118 (close-input-port p)119 (assert (not (input-port-open? p)))120 (assert (= n 1))121 (close-input-port p)122 (assert (not (input-port-open? p)))123 (assert (= n 1)))124125(let* ((n 0)126 (p (make-output-port (lambda () (display #\a))127 (lambda () (set! n (add1 n))))))128 (close-input-port p)129 (assert (output-port-open? p))130 (assert (= n 0))131 (close-output-port p)132 (assert (not (output-port-open? p)))133 (assert (= n 1))134 (close-output-port p)135 (assert (not (output-port-open? p)))136 (assert (= n 1)))137138;; bidirectional ports139140(let* ((b (string))141 (w (lambda (s)142 (set! b (string-append b s))))143 (e (lambda ()144 (positive? (string-length b))))145 (r (lambda ()146 (let ((s b))147 (set! b (substring s 1))148 (string-ref s 0))))149 (i (make-input-port r e void))150 (o (make-output-port w void))151 (p (make-bidirectional-port i o)))152 (assert (input-port? p))153 (assert (output-port? p))154 (assert (input-port-open? p))155 (assert (output-port-open? p))156 (display "quartz ruby" p)157 (newline p)158 (assert (equal? (read p) 'quartz))159 (assert (equal? (read i) 'ruby))160 (display "emerald topaz" p)161 (newline p)162 (close-output-port p)163 (assert (not (output-port-open? o)))164 (assert (not (output-port-open? p)))165 (assert (equal? (read p) 'emerald))166 (assert (equal? (read i) 'topaz))167 (close-input-port p)168 (assert (not (input-port-open? i)))169 (assert (not (input-port-open? p))))170171;; fill buffers172(with-input-from-file "compiler.scm" read-string)173174(print "slow...")175(time176 (with-input-from-file "compiler.scm"177 (lambda ()178 (with-output-to-file "compiler.scm.2"179 (lambda ()180 (copy-port181 (current-input-port) (current-output-port)182 (lambda (port) (read-char port))183 (lambda (x port) (write-char x port))))))))184185(print "fast...")186(time187 (with-input-from-file "compiler.scm"188 (lambda ()189 (with-output-to-file "compiler.scm.2"190 (lambda ()191 (copy-port (current-input-port) (current-output-port)))))))192193(delete-file "compiler.scm.2")194195(define-syntax check196 (syntax-rules ()197 ((_ (expr-head expr-rest ...))198 (check 'expr-head (expr-head expr-rest ...)))199 ((_ name expr)200 (let ((okay (list 'okay)))201 (assert202 (eq? okay203 (condition-case204 (begin (print* name "...")205 (flush-output)206 (let ((output expr))207 (printf "FAIL [ ~S ]\n" output)))208 ((exn i/o file) (printf "OK\n") okay))))))))209210(cond-expand211 ((not mingw32)212213 (define proc (process-fork (lambda () (tcp-accept (tcp-listen 8080)))))214215 (on-exit (lambda () (handle-exceptions exn #f (process-signal proc))))216217 (print "\n\nProcedures check on TCP ports being closed\n")218219 (receive (in out)220 (let lp ()221 (condition-case (tcp-connect "localhost" 8080)222 ((exn i/o net) (lp))))223 (close-output-port out)224 (close-input-port in)225 (check (tcp-addresses in))226 (check (tcp-port-numbers in))227 (check (tcp-abandon-port in))) ; Not sure about abandon-port228229230 ;; This tests for two bugs which occurred on NetBSD and possibly231 ;; other platforms, possibly due to multiprocessing:232 ;; read-line with EINTR would loop endlessly and process-wait would233 ;; signal a condition when interrupted rather than retrying.234 (set-signal-handler! signal/chld void) ; Should be a noop but triggers EINTR235 (receive (in out)236 (create-pipe)237 (receive (pid ok? status)238 (process-wait239 (process-fork240 (lambda ()241 (file-close in) ; close receiving end242 (with-output-to-port (open-output-file* out)243 (lambda ()244 (display "hello, world\n")245 ;; exit prevents buffers from being discarded by implicit _exit246 (exit 0))))))247 (file-close out) ; close sending end248 (assert (equal? '(#t 0 ("hello, world"))249 (list ok? status (read-lines (open-input-file* in)))))))250 )251 (else))252253(print "\n\nProcedures check on output ports being closed\n")254255(with-output-to-file "empty-file" void)256257(call-with-output-file "empty-file"258 (lambda (out)259 (close-output-port out)260 (check (write '(foo) out))261 (check (fprintf out "blabla"))262 (check "print-call-chain" (begin (print-call-chain out) (void)))263 (check (print-error-message (make-property-condition 'exn 'message "foo") out))264 (check "print" (with-output-to-port out265 (lambda () (print "foo"))))266 (check "print*" (with-output-to-port out267 (lambda () (print* "foo"))))268 (check (display "foo" out))269 (check (terminal-port? out)) ; Calls isatty() on C_SCHEME_FALSE?270 (check (newline out))271 (check (write-char #\x out))272 (check (write-line "foo" out))273 (check (write-u8vector '#u8(1 2 3) out))274 ;;(check (port->fileno in))275 (check (flush-output out))276277 #+(not mingw32)278 (begin279 (check (file-test-lock out))280 (check (file-lock out))281 (check (file-lock/blocking out)))282283 (check (write-byte 120 out))284 (check (write-string "foo" #f out))))285286(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-u8vector 5 in))298 (check "read-u8vector!" (let ((dest (make-u8vector 5)))299 (read-u8vector! 5 dest in)))300 #+(not mingw32)301 (begin302 (check (file-test-lock in))303 (check (file-lock in))304 (check (file-lock/blocking in)))305306 (check (read-byte in))307 (check (read-token (constantly #t) in))308 (check (read-string 10 in))309 (check "read-string!" (let ((buf (make-string 10)))310 (read-string! 10 buf in) buf))))311312(print "\nEmbedded NUL bytes in filenames are rejected\n")313(assert-error (with-output-to-file "embedded\x00null-byte" void))314315;;; #978 -- port-position checks for read-line316317(define (read-line/pos p limit) ;; common318 (let ((s (read-line p limit)))319 (let-values (((row col) (port-position p)))320 (list s row col))))321322(define (read-string-line/pos str limit)323 (read-line/pos (open-input-string str) limit))324325(define (read-process-line/pos cmd args limit)326 (let-values (((i o pid) (process cmd args)))327 (let ((rc (read-line/pos i limit)))328 (close-input-port i)329 (close-output-port o)330 rc)))331(define (read-echo-line/pos str limit)332 (read-process-line/pos "echo" (list "-n" str) limit))333334(define (test-port-position proc)335 (test-equal "advance row when encountering delim"336 (proc "abcde\nfghi" 6)337 '("abcde" 2 0))338 (test-equal "reaching limit sets col to limit, and does not advance row"339 (proc "abcdefghi" 6)340 '("abcdef" 1 6))341 (test-equal "delimiter counted in limit" ;; observed behavior, strange342 (proc "abcdef\nghi" 6)343 '("abcdef" 1 6))344 (test-equal "EOF reached"345 (proc "abcde" 6)346 '("abcde" 1 5)))347348(test-group349 "read-line string port position tests"350 (test-port-position read-string-line/pos))351352(test-group "read-string!"353 (let ((in (open-input-string "1234567890"))354 (buf (make-string 5)))355 (test-equal "peek-char won't influence the result of read-string!"356 (peek-char in)357 #\1)358 (test-equal "read-string! won't read past buffer if given #f"359 (read-string! #f buf in)360 5)361 (test-equal "read-string! reads the requested bytes with #f"362 buf363 "12345")364 (test-equal "read-string! won't read past buffer if given #f and offset"365 (read-string! #f buf in 3)366 2)367 (test-equal "read-string! reads the requested bytes with #f and offset"368 buf369 "12367")370 (test-equal "read-string! reads until the end correctly"371 (read-string! #f buf in)372 3)373 (test-equal "read-string! leaves the buffer's tail intact"374 buf375 "89067")376 (test-equal "after peek-char at EOF, read-string! doesn't mutate the buffer"377 (begin (peek-char in)378 (read-string! #f buf in)379 buf)380 "89067"))381 (let ((in (open-input-string "1234567890"))382 (buf (make-string 5)))383 (test-equal "read-string! won't read past buffer if given size"384 (read-string! 10 buf in)385 5)386 (test-equal "read-string! reads the requested bytes with buffer size"387 buf388 "12345")389 (test-equal "read-string! won't read past buffer if given size and offset"390 (read-string! 10 buf in 3)391 2)392 (test-equal "read-string! reads the requested bytes with buffer size and offset"393 buf394 "12367")395 (test-equal "read-string! reads until the end correctly with buffer size"396 (read-string! 10 buf in)397 3)398 (test-equal "read-string! leaves the buffer's tail intact"399 buf400 "89067")401 (test-equal "read-string! at EOF reads nothing"402 (read-string! 10 buf in)403 0)404 (test-equal "read-string! at EOF doesn't mutate the buffer"405 buf406 "89067")))407408(test-group "line endings"409 (let ((s "foo\nbar\rbaz\r\nqux")410 (f (lambda ()411 (test-equal "\\n" (read-line) "foo")412 (test-equal "\\r" (read-line) "bar")413 (test-equal "\\r\\n" (read-line) "baz")414 (test-equal "eof" (read-line) "qux"))))415 (test-group "string port"416 (with-input-from-string s f))417 (test-group "file port"418 (let ((file "mixed-line-endings"))419 (with-output-to-file file (lambda () (display s)))420 (with-input-from-file file f)421 (delete-file* file)))422 (test-group "custom port"423 (let* ((p (open-input-string s))424 (p* (make-input-port (lambda () (read-char p))425 (lambda () (char-ready? p))426 (lambda () (close-input-port p)))))427 (with-input-from-port p* f)))))428429;; Disabled because it requires `echo -n` for430;; the EOF test, and that is not available on all systems.431;; Uncomment locally to run.432#;433(test-group434 "read-line process port position tests"435 (test-port-position read-echo-line/pos))436437;;;438439(test-end)440441(test-exit)