X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/7424deab5dba9d334f57d71ba8c0753dab546ecd..f6f4feb0a2222efcb297e634603621126542e63f:/test-suite/tests/ports.test diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index d134972fa..65c87da10 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -1,28 +1,35 @@ -;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*- +;;;; ports.test --- Guile I/O ports. -*- coding: utf-8; mode: scheme; -*- ;;;; Jim Blandy --- May 1999 ;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010, +;;;; 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. ;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. ;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-ports) - :use-module (test-suite lib) - :use-module (test-suite guile-test) - :use-module (ice-9 popen) - :use-module (ice-9 rdelim)) + #:use-module (test-suite lib) + #:use-module (test-suite guile-test) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (rnrs bytevectors) + #:use-module ((ice-9 binary-ports) #:select (open-bytevector-input-port + open-bytevector-output-port + put-bytevector + get-bytevector-n + get-bytevector-all + unget-bytevector))) (define (display-line . args) (for-each display args) @@ -34,6 +41,13 @@ ;;;; Some general utilities for testing ports. +;; Make sure we are set up for 8-bit Latin-1 data. +(fluid-set! %default-port-encoding "ISO-8859-1") +(for-each (lambda (p) + (set-port-encoding! p (fluid-ref %default-port-encoding))) + (list (current-input-port) (current-output-port) + (current-error-port))) + ;;; Read from PORT until EOF, and return the result as a string. (define (read-all port) (let loop ((chars '())) @@ -49,6 +63,34 @@ string)) + +(with-test-prefix "%default-port-conversion-strategy" + + (pass-if "initial value" + (eq? 'substitute (fluid-ref %default-port-conversion-strategy))) + + (pass-if "file port" + (let ((strategies '(error substitute escape))) + (equal? (map (lambda (s) + (with-fluids ((%default-port-conversion-strategy s)) + (call-with-output-file "/dev/null" + (lambda (p) + (port-conversion-strategy p))))) + strategies) + strategies))) + + (pass-if "(set-port-conversion-strategy! #f sym)" + (begin + (set-port-conversion-strategy! #f 'error) + (and (eq? (fluid-ref %default-port-conversion-strategy) 'error) + (begin + (set-port-conversion-strategy! #f 'substitute) + (eq? (fluid-ref %default-port-conversion-strategy) + 'substitute))))) + +) + + ;;;; Normal file ports. ;;; Write out an s-expression, and read it back. @@ -176,6 +218,359 @@ (string=? line test-string))) (delete-file filename)) +;;; read-line should use the port encoding (not the locale encoding). +(let ((str "ĉu bone?")) + (with-locale "C" + (let* ((filename (test-file)) + (port (open-file filename "wl"))) + (set-port-encoding! port "UTF-8") + (write-line str port) + (let ((in-port (open-input-file filename))) + (set-port-encoding! in-port "UTF-8") + (let ((line (read-line in-port))) + (close-port in-port) + (close-port port) + (pass-if "file: read-line honors port encoding" + (string=? line str)))) + (delete-file filename)))) + +;;; binary mode ignores port encoding +(pass-if "file: binary mode ignores port encoding" + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((filename (test-file)) + (port (open-file filename "w")) + (test-string "一二三") + (binary-test-string + (apply string + (map integer->char + (uniform-vector->list + (string->utf8 test-string)))))) + (write-line test-string port) + (close-port port) + (let* ((in-port (open-file filename "rb")) + (line (read-line in-port))) + (close-port in-port) + (delete-file filename) + (string=? line binary-test-string))))) + +;;; binary mode ignores file coding declaration +(pass-if "file: binary mode ignores file coding declaration" + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((filename (test-file)) + (port (open-file filename "w")) + (test-string "一二三") + (binary-test-string + (apply string + (map integer->char + (uniform-vector->list + (string->utf8 test-string)))))) + (write-line ";; coding: utf-8" port) + (write-line test-string port) + (close-port port) + (let* ((in-port (open-file filename "rb")) + (line1 (read-line in-port)) + (line2 (read-line in-port))) + (close-port in-port) + (delete-file filename) + (string=? line2 binary-test-string))))) + +;; open-file ignores file coding declaration by default +(pass-if "file: open-file ignores coding declaration by default" + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((filename (test-file)) + (port (open-output-file filename)) + (test-string "€100")) + (write-line ";; coding: iso-8859-15" port) + (write-line test-string port) + (close-port port) + (let* ((in-port (open-input-file filename)) + (line1 (read-line in-port)) + (line2 (read-line in-port))) + (close-port in-port) + (delete-file filename) + (string=? line2 test-string))))) + +;; open-input-file with guess-encoding honors coding declaration +(pass-if "file: open-input-file with guess-encoding honors coding declaration" + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((filename (test-file)) + (port (open-output-file filename)) + (test-string "€100")) + (set-port-encoding! port "iso-8859-15") + (write-line ";; coding: iso-8859-15" port) + (write-line test-string port) + (close-port port) + (let* ((in-port (open-input-file filename + #:guess-encoding #t)) + (line1 (read-line in-port)) + (line2 (read-line in-port))) + (close-port in-port) + (delete-file filename) + (string=? line2 test-string))))) + +(with-test-prefix "keyword arguments for file openers" + (with-fluids ((%default-port-encoding "UTF-8")) + (let ((filename (test-file))) + + (with-test-prefix "write #:encoding" + + (pass-if-equal "open-file" + #vu8(116 0 101 0 115 0 116 0) + (let ((port (open-file filename "w" + #:encoding "UTF-16LE"))) + (display "test" port) + (close-port port)) + (let* ((port (open-file filename "rb")) + (bv (get-bytevector-all port))) + (close-port port) + bv)) + + (pass-if-equal "open-output-file" + #vu8(116 0 101 0 115 0 116 0) + (let ((port (open-output-file filename + #:encoding "UTF-16LE"))) + (display "test" port) + (close-port port)) + (let* ((port (open-file filename "rb")) + (bv (get-bytevector-all port))) + (close-port port) + bv)) + + (pass-if-equal "call-with-output-file" + #vu8(116 0 101 0 115 0 116 0) + (call-with-output-file filename + (lambda (port) + (display "test" port)) + #:encoding "UTF-16LE") + (let* ((port (open-file filename "rb")) + (bv (get-bytevector-all port))) + (close-port port) + bv)) + + (pass-if-equal "with-output-to-file" + #vu8(116 0 101 0 115 0 116 0) + (with-output-to-file filename + (lambda () + (display "test")) + #:encoding "UTF-16LE") + (let* ((port (open-file filename "rb")) + (bv (get-bytevector-all port))) + (close-port port) + bv)) + + (pass-if-equal "with-error-to-file" + #vu8(116 0 101 0 115 0 116 0) + (with-error-to-file + filename + (lambda () + (display "test" (current-error-port))) + #:encoding "UTF-16LE") + (let* ((port (open-file filename "rb")) + (bv (get-bytevector-all port))) + (close-port port) + bv))) + + (with-test-prefix "write #:binary" + + (pass-if-equal "open-output-file" + "ISO-8859-1" + (let* ((port (open-output-file filename #:binary #t)) + (enc (port-encoding port))) + (close-port port) + enc)) + + (pass-if-equal "call-with-output-file" + "ISO-8859-1" + (call-with-output-file filename port-encoding #:binary #t)) + + (pass-if-equal "with-output-to-file" + "ISO-8859-1" + (with-output-to-file filename + (lambda () (port-encoding (current-output-port))) + #:binary #t)) + + (pass-if-equal "with-error-to-file" + "ISO-8859-1" + (with-error-to-file + filename + (lambda () (port-encoding (current-error-port))) + #:binary #t))) + + (with-test-prefix "read #:encoding" + + (pass-if-equal "open-file read #:encoding" + "test" + (call-with-output-file filename + (lambda (port) + (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) + (let* ((port (open-file filename "r" #:encoding "UTF-16LE")) + (str (read-string port))) + (close-port port) + str)) + + (pass-if-equal "open-input-file #:encoding" + "test" + (call-with-output-file filename + (lambda (port) + (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) + (let* ((port (open-input-file filename #:encoding "UTF-16LE")) + (str (read-string port))) + (close-port port) + str)) + + (pass-if-equal "call-with-input-file #:encoding" + "test" + (call-with-output-file filename + (lambda (port) + (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) + (call-with-input-file filename + read-string + #:encoding "UTF-16LE")) + + (pass-if-equal "with-input-from-file #:encoding" + "test" + (call-with-output-file filename + (lambda (port) + (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) + (with-input-from-file filename + read-string + #:encoding "UTF-16LE"))) + + (with-test-prefix "read #:binary" + + (pass-if-equal "open-input-file" + "ISO-8859-1" + (let* ((port (open-input-file filename #:binary #t)) + (enc (port-encoding port))) + (close-port port) + enc)) + + (pass-if-equal "call-with-input-file" + "ISO-8859-1" + (call-with-input-file filename port-encoding #:binary #t)) + + (pass-if-equal "with-input-from-file" + "ISO-8859-1" + (with-input-from-file filename + (lambda () (port-encoding (current-input-port))) + #:binary #t))) + + (with-test-prefix "#:guess-encoding with coding declaration" + + (pass-if-equal "open-file" + "€100" + (with-output-to-file filename + (lambda () + (write-line "test") + (write-line "; coding: ISO-8859-15") + (write-line "€100")) + #:encoding "ISO-8859-15") + (let* ((port (open-file filename "r" + #:guess-encoding #t + #:encoding "UTF-16LE")) + (str (begin (read-line port) + (read-line port) + (read-line port)))) + (close-port port) + str)) + + (pass-if-equal "open-input-file" + "€100" + (with-output-to-file filename + (lambda () + (write-line "test") + (write-line "; coding: ISO-8859-15") + (write-line "€100")) + #:encoding "ISO-8859-15") + (let* ((port (open-input-file filename + #:guess-encoding #t + #:encoding "UTF-16LE")) + (str (begin (read-line port) + (read-line port) + (read-line port)))) + (close-port port) + str)) + + (pass-if-equal "call-with-input-file" + "€100" + (with-output-to-file filename + (lambda () + (write-line "test") + (write-line "; coding: ISO-8859-15") + (write-line "€100")) + #:encoding "ISO-8859-15") + (call-with-input-file filename + (lambda (port) + (read-line port) + (read-line port) + (read-line port)) + #:guess-encoding #t + #:encoding "UTF-16LE")) + + (pass-if-equal "with-input-from-file" + "€100" + (with-output-to-file filename + (lambda () + (write-line "test") + (write-line "; coding: ISO-8859-15") + (write-line "€100")) + #:encoding "ISO-8859-15") + (with-input-from-file filename + (lambda () + (read-line) + (read-line) + (read-line)) + #:guess-encoding #t + #:encoding "UTF-16LE"))) + + (with-test-prefix "#:guess-encoding without coding declaration" + + (pass-if-equal "open-file" + "€100" + (with-output-to-file filename + (lambda () (write-line "€100")) + #:encoding "ISO-8859-15") + (let* ((port (open-file filename "r" + #:guess-encoding #t + #:encoding "ISO-8859-15")) + (str (read-line port))) + (close-port port) + str)) + + (pass-if-equal "open-input-file" + "€100" + (with-output-to-file filename + (lambda () (write-line "€100")) + #:encoding "ISO-8859-15") + (let* ((port (open-input-file filename + #:guess-encoding #t + #:encoding "ISO-8859-15")) + (str (read-line port))) + (close-port port) + str)) + + (pass-if-equal "call-with-input-file" + "€100" + (with-output-to-file filename + (lambda () (write-line "€100")) + #:encoding "ISO-8859-15") + (call-with-input-file filename + read-line + #:guess-encoding #t + #:encoding "ISO-8859-15")) + + (pass-if-equal "with-input-from-file" + "€100" + (with-output-to-file filename + (lambda () (write-line "€100")) + #:encoding "ISO-8859-15") + (with-input-from-file filename + read-line + #:guess-encoding #t + #:encoding "ISO-8859-15"))) + + (delete-file filename)))) + ;;; ungetting characters and strings. (with-input-from-string "walk on the moon\nmoon" (lambda () @@ -281,7 +676,7 @@ (string-ref text 0)))))) ;; seeking an output string. - (let* ((text "123456789") + (let* ((text (string-copy "123456789")) (len (string-length text)) (result (call-with-output-string (lambda (p) @@ -301,7 +696,262 @@ (string-set! text 0 #\a) (string-set! text (- len 1) #\b) (pass-if "output check" - (string=? text result)))) + (string=? text result))) + + (pass-if "encoding failure leads to exception" + ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'. + ;; See the discussion at , for details. + (catch 'encoding-error + (lambda () + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (let ((p (open-input-string "λ"))) ; raise an exception + #f))) + (lambda (key . rest) + #t) + (lambda (key . rest) + ;; At this point, the port-table mutex used to be still held, + ;; hence the deadlock. This situation would occur when trying + ;; to print a backtrace, for instance. + (input-port? (open-input-string "foo"))))) + + (pass-if "%default-port-encoding is honored" + (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3"))) + (equal? (map (lambda (e) + (with-fluids ((%default-port-encoding e)) + (call-with-output-string + (lambda (p) + (and (string=? e (port-encoding p)) + (display (port-encoding p) p)))))) + encodings) + encodings))) + + (pass-if "%default-port-conversion-strategy is honored" + (let ((strategies '(error substitute escape))) + (equal? (map (lambda (s) + (with-fluids ((%default-port-conversion-strategy s)) + (call-with-output-string + (lambda (p) + (and (eq? s (port-conversion-strategy p)) + (begin + (set-port-conversion-strategy! p s) + (display (port-conversion-strategy p) + p))))))) + strategies) + (map symbol->string strategies)))) + + (pass-if "suitable encoding [latin-1]" + (let ((str "hello, world")) + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (equal? str + (with-output-to-string + (lambda () + (display str))))))) + + (pass-if "suitable encoding [latin-3]" + (let ((str "ĉu bone?")) + (with-fluids ((%default-port-encoding "ISO-8859-3")) + (equal? str + (with-output-to-string + (lambda () + (display str))))))) + + (pass-if "wrong encoding, error" + (let ((str "ĉu bone?")) + (catch 'encoding-error + (lambda () + ;; Latin-1 cannot represent ‘ĉ’. + (with-fluids ((%default-port-encoding "ISO-8859-1") + (%default-port-conversion-strategy 'error)) + (with-output-to-string + (lambda () + (display str)))) + #f) ; so the test really fails here + (lambda (key subr message errno port chr) + (and (eqv? chr #\ĉ) + (string? (strerror errno))))))) + + (pass-if "wrong encoding, substitute" + (let ((str "ĉu bone?")) + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (string=? (with-output-to-string + (lambda () + (set-port-conversion-strategy! (current-output-port) + 'substitute) + (display str))) + "?u bone?")))) + + (pass-if "wrong encoding, escape" + (let ((str "ĉu bone?")) + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (string=? (with-output-to-string + (lambda () + (set-port-conversion-strategy! (current-output-port) + 'escape) + (display str))) + "\\u0109u bone?")))) + + (pass-if "peek-char [latin-1]" + (let ((p (with-fluids ((%default-port-encoding #f)) + (open-input-string "hello, world")))) + (and (char=? (peek-char p) #\h) + (char=? (peek-char p) #\h) + (char=? (peek-char p) #\h) + (= (port-line p) 0) + (= (port-column p) 0)))) + + (pass-if "peek-char [utf-8]" + (let ((p (with-fluids ((%default-port-encoding "UTF-8")) + (open-input-string "안녕하세요")))) + (and (char=? (peek-char p) #\안) + (char=? (peek-char p) #\안) + (char=? (peek-char p) #\안) + (= (port-line p) 0) + (= (port-column p) 0)))) + + (pass-if "peek-char [utf-16]" + (let ((p (with-fluids ((%default-port-encoding "UTF-16BE")) + (open-input-string "안녕하세요")))) + (and (char=? (peek-char p) #\안) + (char=? (peek-char p) #\안) + (char=? (peek-char p) #\안) + (= (port-line p) 0) + (= (port-column p) 0)))) + + ;; Mini DSL to test decoding error handling. + (letrec-syntax ((decoding-error? + (syntax-rules () + ((_ port exp) + (catch 'decoding-error + (lambda () + (pk 'exp exp) + #f) + (lambda (key subr message errno p) + (and (eq? p port) + (not (= 0 errno)))))))) + (make-check + (syntax-rules (-> error eof) + ((_ port (proc -> error)) + (if (eq? 'substitute + (port-conversion-strategy port)) + (eqv? (proc port) #\?) + (decoding-error? port (proc port)))) + ((_ port (proc -> eof)) + (eof-object? (proc port))) + ((_ port (proc -> char)) + (eqv? (proc port) char)))) + (make-checks + (syntax-rules () + ((_ port check ...) + (and (make-check port check) ...)))) + (make-peek+read-checks + (syntax-rules () + ((_ port (result ...) e1 expected ...) + (make-peek+read-checks port + (result ... + (peek-char -> e1) + (read-char -> e1)) + expected ...)) + ((_ port (result ...)) + (make-checks port result ...)) + ((_ port #f e1 expected ...) + (make-peek+read-checks port + ((peek-char -> e1) + (read-char -> e1)) + expected ...)))) + + (test-decoding-error* + (syntax-rules () + ((_ sequence encoding strategy (expected ...)) + (begin + (pass-if (format #f "test-decoding-error: ~s ~s ~s" + 'sequence encoding strategy) + (let ((p (open-bytevector-input-port + (u8-list->bytevector 'sequence)))) + (set-port-encoding! p encoding) + (set-port-conversion-strategy! p strategy) + (make-checks p + (read-char -> expected) ...))) + + ;; Generate the same test, but with one + ;; `peek-char' call before each `read-char'. + ;; Both should yield the same result. + (pass-if (format #f "test-decoding-error: ~s ~s ~s + peek-char" + 'sequence encoding strategy) + (let ((p (open-bytevector-input-port + (u8-list->bytevector 'sequence)))) + (set-port-encoding! p encoding) + (set-port-conversion-strategy! p strategy) + (make-peek+read-checks p #f expected + ...))))))) + (test-decoding-error + (syntax-rules () + ((_ sequence encoding (expected ...)) + (begin + (test-decoding-error* sequence encoding 'error + (expected ...)) + + ;; `escape' should behave exactly like `error'. + (test-decoding-error* sequence encoding 'escape + (expected ...)) + + (test-decoding-error* sequence encoding 'substitute + (expected ...))))))) + + (test-decoding-error (255 65 66 67) "UTF-8" + (error #\A #\B #\C eof)) + + (test-decoding-error (255 206 187 206 188) "UTF-8" + (error #\λ #\μ eof)) + + (test-decoding-error (206 187 206) "UTF-8" + ;; Unterminated sequence. + (#\λ error eof)) + + ;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7 + ;; of the "Conformance" chapter of Unicode 6.0.0.) + + (test-decoding-error (#xc0 #x80 #x41) "UTF-8" + (error ;; C0: should be in the C2..DF range + error ;; 80: invalid + #\A + eof)) + + (test-decoding-error (#xc2 #x41 #x42) "UTF-8" + ;; Section 3.9 of Unicode 6.0.0 reads: + ;; "If the converter encounters an ill-formed UTF-8 code unit + ;; sequence which starts with a valid first byte, but which does + ;; not continue with valid successor bytes (see Table 3-7), it + ;; must not consume the successor bytes". + ;; Glibc/libiconv do not conform to it and instead swallow the + ;; #x41. This example appears literally in Section 3.9. + (error ;; 41: invalid successor + #\A ;; 41: valid starting byte + #\B + eof)) + + (test-decoding-error (#xf0 #x80 #x80 #x41) "UTF-8" + ;; According to Unicode 6.0.0, Section 3.9, "the only formal + ;; requirement mandated by Unicode conformance for a converter is + ;; that the <41> be processed and correctly interpreted as + ;; ". + (error ;; 2nd byte should be in the A0..BF range + error ;; 80: not a valid starting byte + error ;; 80: not a valid starting byte + #\A + eof)) + + (test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8" + (error ;; 3rd byte should be in the 80..BF range + #\A + #\B + eof)) + + (test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8" + (error ;; 2nd byte should be in the 90..BF range + error ;; 88: not a valid starting byte + error ;; 88: not a valid starting byte + error ;; 88: not a valid starting byte + eof)))) (with-test-prefix "call-with-output-string" @@ -538,6 +1188,176 @@ (while (not (eof-object? (read-char port)))) (= 8 (port-column port)))))) +(with-test-prefix "port-line" + + ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas + ;; scm_t_port actually holds a long; this restricted the range on 64-bit + ;; systems + (pass-if "set most-positive-fixnum/2" + (let ((n (quotient most-positive-fixnum 2)) + (port (open-output-string))) + (set-port-line! port n) + (eqv? n (port-line port))))) + +(with-test-prefix "port-encoding" + + (pass-if-exception "set-port-encoding!, wrong encoding" + exception:miscellaneous-error + (let ((p (open-input-string ""))) + (set-port-encoding! p "does-not-exist") + (read p))) + + (pass-if-exception "%default-port-encoding, wrong encoding" + exception:miscellaneous-error + (read (with-fluids ((%default-port-encoding "does-not-exist")) + (open-input-string ""))))) + +;;; +;;; port-for-each +;;; + +(with-test-prefix "port-for-each" + + ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to + ;; its iterator func if a port was inaccessible in the last gc mark but + ;; the lazy sweeping has not yet reached it to remove it from the port + ;; table (scm_i_port_table). Provoking those gc conditions is a little + ;; tricky, but the following code made it happen in 1.8.2. + (pass-if "passing freed cell" + (let ((lst '())) + ;; clear out the heap + (gc) (gc) (gc) + ;; allocate cells so the opened ports aren't at the start of the heap + (make-list 1000) + (open-input-file "/dev/null") + (make-list 1000) + (open-input-file "/dev/null") + ;; this gc leaves the above ports unmarked, ie. inaccessible + (gc) + ;; but they're still in the port table, so this sees them + (port-for-each (lambda (port) + (set! lst (cons port lst)))) + ;; this forces completion of the sweeping + (gc) (gc) (gc) + ;; and (if the bug is present) the cells accumulated in LST are now + ;; freed cells, which give #f from `port?' + (not (memq #f (map port? lst)))))) + +(with-test-prefix + "fdes->port" + (pass-if "fdes->ports finds port" + (let ((port (open-file (test-file) "w"))) + + (not (not (memq port (fdes->ports (port->fdes port)))))))) + +;;; +;;; seek +;;; + +(with-test-prefix "seek" + + (with-test-prefix "file port" + + (pass-if "SEEK_CUR" + (call-with-output-file (test-file) + (lambda (port) + (display "abcde" port))) + (let ((port (open-file (test-file) "r"))) + (read-char port) + (seek port 2 SEEK_CUR) + (eqv? #\d (read-char port)))) + + (pass-if "SEEK_SET" + (call-with-output-file (test-file) + (lambda (port) + (display "abcde" port))) + (let ((port (open-file (test-file) "r"))) + (read-char port) + (seek port 3 SEEK_SET) + (eqv? #\d (read-char port)))) + + (pass-if "SEEK_END" + (call-with-output-file (test-file) + (lambda (port) + (display "abcde" port))) + (let ((port (open-file (test-file) "r"))) + (read-char port) + (seek port -2 SEEK_END) + (eqv? #\d (read-char port)))))) + +;;; +;;; truncate-file +;;; + +(with-test-prefix "truncate-file" + + (pass-if-exception "flonum file" exception:wrong-type-arg + (truncate-file 1.0 123)) + + (pass-if-exception "frac file" exception:wrong-type-arg + (truncate-file 7/3 123)) + + (with-test-prefix "filename" + + (pass-if-exception "flonum length" exception:wrong-type-arg + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (truncate-file (test-file) 1.0)) + + (pass-if "shorten" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (truncate-file (test-file) 1) + (eqv? 1 (stat:size (stat (test-file))))) + + (pass-if-exception "shorten to current pos" exception:miscellaneous-error + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (truncate-file (test-file)))) + + (with-test-prefix "file descriptor" + + (pass-if "shorten" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let ((fd (open-fdes (test-file) O_RDWR))) + (truncate-file fd 1) + (close-fdes fd)) + (eqv? 1 (stat:size (stat (test-file))))) + + (pass-if "shorten to current pos" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let ((fd (open-fdes (test-file) O_RDWR))) + (seek fd 1 SEEK_SET) + (truncate-file fd) + (close-fdes fd)) + (eqv? 1 (stat:size (stat (test-file)))))) + + (with-test-prefix "file port" + + (pass-if "shorten" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let ((port (open-file (test-file) "r+"))) + (truncate-file port 1)) + (eqv? 1 (stat:size (stat (test-file))))) + + (pass-if "shorten to current pos" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let ((port (open-file (test-file) "r+"))) + (read-char port) + (truncate-file port)) + (eqv? 1 (stat:size (stat (test-file))))))) + ;;;; testing read-delimited and friends @@ -577,6 +1397,90 @@ (char-ready?)))))) +;;;; pending-eof behavior + +(with-test-prefix "pending EOF behavior" + ;; Make a test port that will produce the given sequence. Each + ;; element of 'lst' may be either a character or #f (which means EOF). + (define (test-soft-port . lst) + (make-soft-port + (vector (lambda (c) #f) ; write char + (lambda (s) #f) ; write string + (lambda () #f) ; flush + (lambda () ; read char + (let ((c (car lst))) + (set! lst (cdr lst)) + c)) + (lambda () #f)) ; close + "rw")) + + (define (call-with-port p proc) + (dynamic-wind + (lambda () #f) + (lambda () (proc p)) + (lambda () (close-port p)))) + + (define (call-with-test-file str proc) + (let ((filename (test-file))) + (dynamic-wind + (lambda () (call-with-output-file filename + (lambda (p) (display str p)))) + (lambda () (call-with-input-file filename proc)) + (lambda () (delete-file (test-file)))))) + + (pass-if "peek-char does not swallow EOF (soft port)" + (call-with-port (test-soft-port #\a #f #\b) + (lambda (p) + (and (char=? #\a (peek-char p)) + (char=? #\a (read-char p)) + (eof-object? (peek-char p)) + (eof-object? (read-char p)) + (char=? #\b (peek-char p)) + (char=? #\b (read-char p)))))) + + (pass-if "unread clears pending EOF (soft port)" + (call-with-port (test-soft-port #\a #f #\b) + (lambda (p) + (and (char=? #\a (read-char p)) + (eof-object? (peek-char p)) + (begin (unread-char #\u p) + (char=? #\u (read-char p))))))) + + (pass-if "unread clears pending EOF (string port)" + (call-with-input-string "a" + (lambda (p) + (and (char=? #\a (read-char p)) + (eof-object? (peek-char p)) + (begin (unread-char #\u p) + (char=? #\u (read-char p))))))) + + (pass-if "unread clears pending EOF (file port)" + (call-with-test-file + "a" + (lambda (p) + (and (char=? #\a (read-char p)) + (eof-object? (peek-char p)) + (begin (unread-char #\u p) + (char=? #\u (read-char p))))))) + + (pass-if "seek clears pending EOF (string port)" + (call-with-input-string "a" + (lambda (p) + (and (char=? #\a (read-char p)) + (eof-object? (peek-char p)) + (begin (seek p 0 SEEK_SET) + (char=? #\a (read-char p))))))) + + (pass-if "seek clears pending EOF (file port)" + (call-with-test-file + "a" + (lambda (p) + (and (char=? #\a (read-char p)) + (eof-object? (peek-char p)) + (begin (seek p 0 SEEK_SET) + (char=? #\a (read-char p)))))))) + + ;;;; Close current-input-port, and make sure everyone can handle it. (with-test-prefix "closing current-input-port" @@ -590,3 +1494,358 @@ (procedure))))) (list read read-char read-line) '("read" "read-char" "read-line"))) + + + +(with-test-prefix "setvbuf" + + (pass-if "line/column number preserved" + ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's + ;; line and/or column number. + (call-with-output-file (test-file) + (lambda (p) + (display "This is GNU Guile.\nWelcome." p))) + (call-with-input-file (test-file) + (lambda (p) + (and (eqv? #\T (read-char p)) + (let ((line (port-line p)) + (col (port-column p))) + (and (= line 0) (= col 1) + (begin + (setvbuf p _IOFBF 777) + (let ((line* (port-line p)) + (col* (port-column p))) + (and (= line line*) + (= col col*))))))))))) + + + +(pass-if-equal "unget-bytevector" + #vu8(10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 200 201 202 203 + 1 2 3 4 251 253 254 255) + (let ((port (open-bytevector-input-port #vu8(1 2 3 4 251 253 254 255)))) + (unget-bytevector port #vu8(200 201 202 203)) + (unget-bytevector port #vu8(20 21 22 23 24)) + (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 4) + (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 2 2) + (unget-bytevector port #vu8(10 11)) + (get-bytevector-all port))) + + + +(with-test-prefix "unicode byte-order marks (BOMs)" + + (define (bv-read-test* encoding bv proc) + (let ((port (open-bytevector-input-port bv))) + (set-port-encoding! port encoding) + (proc port))) + + (define (bv-read-test encoding bv) + (bv-read-test* encoding bv read-string)) + + (define (bv-write-test* encoding proc) + (call-with-values + (lambda () (open-bytevector-output-port)) + (lambda (port get-bytevector) + (set-port-encoding! port encoding) + (proc port) + (get-bytevector)))) + + (define (bv-write-test encoding str) + (bv-write-test* encoding + (lambda (p) + (display str p)))) + + (pass-if-equal "BOM not discarded from Latin-1 stream" + "\xEF\xBB\xBF\x61" + (bv-read-test "ISO-8859-1" #vu8(#xEF #xBB #xBF #x61))) + + (pass-if-equal "BOM not discarded from Latin-2 stream" + "\u010F\u0165\u017C\x61" + (bv-read-test "ISO-8859-2" #vu8(#xEF #xBB #xBF #x61))) + + (pass-if-equal "BOM not discarded from UTF-16BE stream" + "\uFEFF\x61" + (bv-read-test "UTF-16BE" #vu8(#xFE #xFF #x00 #x61))) + + (pass-if-equal "BOM not discarded from UTF-16LE stream" + "\uFEFF\x61" + (bv-read-test "UTF-16LE" #vu8(#xFF #xFE #x61 #x00))) + + (pass-if-equal "BOM not discarded from UTF-32BE stream" + "\uFEFF\x61" + (bv-read-test "UTF-32BE" #vu8(#x00 #x00 #xFE #xFF + #x00 #x00 #x00 #x61))) + + (pass-if-equal "BOM not discarded from UTF-32LE stream" + "\uFEFF\x61" + (bv-read-test "UTF-32LE" #vu8(#xFF #xFE #x00 #x00 + #x61 #x00 #x00 #x00))) + + (pass-if-equal "BOM not written to UTF-8 stream" + #vu8(#x61) + (bv-write-test "UTF-8" "a")) + + (pass-if-equal "BOM not written to UTF-16BE stream" + #vu8(#x00 #x61) + (bv-write-test "UTF-16BE" "a")) + + (pass-if-equal "BOM not written to UTF-16LE stream" + #vu8(#x61 #x00) + (bv-write-test "UTF-16LE" "a")) + + (pass-if-equal "BOM not written to UTF-32BE stream" + #vu8(#x00 #x00 #x00 #x61) + (bv-write-test "UTF-32BE" "a")) + + (pass-if-equal "BOM not written to UTF-32LE stream" + #vu8(#x61 #x00 #x00 #x00) + (bv-write-test "UTF-32LE" "a")) + + (pass-if "Don't read from the port unless user asks to" + (let* ((p (make-soft-port + (vector + (lambda (c) #f) ; write char + (lambda (s) #f) ; write string + (lambda () #f) ; flush + (lambda () (throw 'fail)) ; read char + (lambda () #f)) + "rw"))) + (set-port-encoding! p "UTF-16") + (display "abc" p) + (set-port-encoding! p "UTF-32") + (display "def" p) + #t)) + + ;; TODO: test that input and output streams are independent when + ;; appropriate, and linked when appropriate. + + (pass-if-equal "BOM discarded from start of UTF-8 stream" + "a" + (bv-read-test "Utf-8" #vu8(#xEF #xBB #xBF #x61))) + + (pass-if-equal "BOM discarded from start of UTF-8 stream after seek to 0" + '(#\a "a") + (bv-read-test* "uTf-8" #vu8(#xEF #xBB #xBF #x61) + (lambda (p) + (let ((c (read-char p))) + (seek p 0 SEEK_SET) + (let ((s (read-string p))) + (list c s)))))) + + (pass-if-equal "Only one BOM discarded from start of UTF-8 stream" + "\uFEFFa" + (bv-read-test "UTF-8" #vu8(#xEF #xBB #xBF #xEF #xBB #xBF #x61))) + + (pass-if-equal "BOM not discarded from UTF-8 stream after seek to > 0" + "\uFEFFb" + (bv-read-test* "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62) + (lambda (p) + (seek p 1 SEEK_SET) + (read-string p)))) + + (pass-if-equal "BOM not discarded unless at start of UTF-8 stream" + "a\uFEFFb" + (bv-read-test "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62))) + + (pass-if-equal "BOM (BE) written to start of UTF-16 stream" + #vu8(#xFE #xFF #x00 #x61 #x00 #x62) + (bv-write-test "UTF-16" "ab")) + + (pass-if-equal "BOM (BE) written to UTF-16 stream after set-port-encoding!" + #vu8(#xFE #xFF #x00 #x61 #x00 #x62 #xFE #xFF #x00 #x63 #x00 #x64) + (bv-write-test* "UTF-16" + (lambda (p) + (display "ab" p) + (set-port-encoding! p "UTF-16") + (display "cd" p)))) + + (pass-if-equal "BOM discarded from start of UTF-16 stream (BE)" + "a" + (bv-read-test "UTF-16" #vu8(#xFE #xFF #x00 #x61))) + + (pass-if-equal "BOM discarded from start of UTF-16 stream (BE) after seek to 0" + '(#\a "a") + (bv-read-test* "utf-16" #vu8(#xFE #xFF #x00 #x61) + (lambda (p) + (let ((c (read-char p))) + (seek p 0 SEEK_SET) + (let ((s (read-string p))) + (list c s)))))) + + (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (BE)" + "\uFEFFa" + (bv-read-test "Utf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61))) + + (pass-if-equal "BOM not discarded from UTF-16 stream (BE) after seek to > 0" + "\uFEFFa" + (bv-read-test* "uTf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61) + (lambda (p) + (seek p 2 SEEK_SET) + (read-string p)))) + + (pass-if-equal "BOM not discarded unless at start of UTF-16 stream" + "a\uFEFFb" + (bv-read-test "utf-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62))) + + (pass-if-equal "BOM discarded from start of UTF-16 stream (LE)" + "a" + (bv-read-test "UTF-16" #vu8(#xFF #xFE #x61 #x00))) + + (pass-if-equal "BOM discarded from start of UTF-16 stream (LE) after seek to 0" + '(#\a "a") + (bv-read-test* "Utf-16" #vu8(#xFF #xFE #x61 #x00) + (lambda (p) + (let ((c (read-char p))) + (seek p 0 SEEK_SET) + (let ((s (read-string p))) + (list c s)))))) + + (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (LE)" + "\uFEFFa" + (bv-read-test "UTf-16" #vu8(#xFF #xFE #xFF #xFE #x61 #x00))) + + (pass-if-equal "BOM discarded from start of UTF-32 stream (BE)" + "a" + (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF + #x00 #x00 #x00 #x61))) + + (pass-if-equal "BOM discarded from start of UTF-32 stream (BE) after seek to 0" + '(#\a "a") + (bv-read-test* "utF-32" #vu8(#x00 #x00 #xFE #xFF + #x00 #x00 #x00 #x61) + (lambda (p) + (let ((c (read-char p))) + (seek p 0 SEEK_SET) + (let ((s (read-string p))) + (list c s)))))) + + (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (BE)" + "\uFEFFa" + (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF + #x00 #x00 #xFE #xFF + #x00 #x00 #x00 #x61))) + + (pass-if-equal "BOM not discarded from UTF-32 stream (BE) after seek to > 0" + "\uFEFFa" + (bv-read-test* "UtF-32" #vu8(#x00 #x00 #xFE #xFF + #x00 #x00 #xFE #xFF + #x00 #x00 #x00 #x61) + (lambda (p) + (seek p 4 SEEK_SET) + (read-string p)))) + + (pass-if-equal "BOM discarded within UTF-16 stream (BE) after set-port-encoding!" + "ab" + (bv-read-test* "UTF-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62) + (lambda (p) + (let ((a (read-char p))) + (set-port-encoding! p "UTF-16") + (string a (read-char p)))))) + + (pass-if-equal "BOM discarded within UTF-16 stream (LE,BE) after set-port-encoding!" + "ab" + (bv-read-test* "utf-16" #vu8(#x00 #x61 #xFF #xFE #x62 #x00) + (lambda (p) + (let ((a (read-char p))) + (set-port-encoding! p "UTF-16") + (string a (read-char p)))))) + + (pass-if-equal "BOM discarded within UTF-32 stream (BE) after set-port-encoding!" + "ab" + (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61 + #x00 #x00 #xFE #xFF + #x00 #x00 #x00 #x62) + (lambda (p) + (let ((a (read-char p))) + (set-port-encoding! p "UTF-32") + (string a (read-char p)))))) + + (pass-if-equal "BOM discarded within UTF-32 stream (LE,BE) after set-port-encoding!" + "ab" + (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61 + #xFF #xFE #x00 #x00 + #x62 #x00 #x00 #x00) + (lambda (p) + (let ((a (read-char p))) + (set-port-encoding! p "UTF-32") + (string a (read-char p)))))) + + (pass-if-equal "BOM not discarded unless at start of UTF-32 stream" + "a\uFEFFb" + (bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61 + #x00 #x00 #xFE #xFF + #x00 #x00 #x00 #x62))) + + (pass-if-equal "BOM discarded from start of UTF-32 stream (LE)" + "a" + (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00 + #x61 #x00 #x00 #x00))) + + (pass-if-equal "BOM discarded from start of UTF-32 stream (LE) after seek to 0" + '(#\a "a") + (bv-read-test* "UTf-32" #vu8(#xFF #xFE #x00 #x00 + #x61 #x00 #x00 #x00) + (lambda (p) + (let ((c (read-char p))) + (seek p 0 SEEK_SET) + (let ((s (read-string p))) + (list c s)))))) + + (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (LE)" + "\uFEFFa" + (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00 + #xFF #xFE #x00 #x00 + #x61 #x00 #x00 #x00)))) + + + +(define-syntax-rule (with-load-path path body ...) + (let ((new path) + (old %load-path)) + (dynamic-wind + (lambda () + (set! %load-path new)) + (lambda () + body ...) + (lambda () + (set! %load-path old))))) + +(with-test-prefix "%file-port-name-canonicalization" + + (pass-if-equal "absolute file name & empty %load-path entry" "/dev/null" + ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead + ;; of "/dev/null". See + ;; + ;; for a discussion. + (with-load-path (cons "" (delete "/" %load-path)) + (with-fluids ((%file-port-name-canonicalization 'relative)) + (port-filename (open-input-file "/dev/null"))))) + + (pass-if-equal "relative canonicalization with /" "dev/null" + (with-load-path (cons "/" %load-path) + (with-fluids ((%file-port-name-canonicalization 'relative)) + (port-filename (open-input-file "/dev/null"))))) + + (pass-if-equal "relative canonicalization from ice-9" "ice-9/q.scm" + ;; If an entry in %LOAD-PATH is not canonical, then + ;; `scm_i_relativize_path' is unable to do its job. + (if (equal? (map canonicalize-path %load-path) %load-path) + (with-fluids ((%file-port-name-canonicalization 'relative)) + (port-filename + (open-input-file (%search-load-path "ice-9/q.scm")))) + (throw 'unresolved))) + + (pass-if-equal "absolute canonicalization from ice-9" + (canonicalize-path + (string-append (assoc-ref %guile-build-info 'top_srcdir) + "/module/ice-9/q.scm")) + (with-fluids ((%file-port-name-canonicalization 'absolute)) + (port-filename (open-input-file (%search-load-path "ice-9/q.scm")))))) + +(delete-file (test-file)) + +;;; Local Variables: +;;; eval: (put 'test-decoding-error 'scheme-indent-function 3) +;;; eval: (put 'with-load-path 'scheme-indent-function 1) +;;; End: