* tests/ports.test (non-blocking-I/O): a couple more details:

[bpt/guile.git] / test-suite / tests / ports.test

;;;; ports.test --- test suite for Guile I/O ports     -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
;;;;
;;;;    Copyright (C) 1999 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.
;;;; 
;;;; This program 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.
;;;; 
;;;; 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

(use-modules (test-suite lib)
             (ice-9 popen))

(define (display-line . args)
  (for-each display args)
  (newline))

(define (test-file)
  (tmpnam))

\f
;;;; Some general utilities for testing ports.

;;; Read from PORT until EOF, and return the result as a string.
(define (read-all port)
  (let loop ((chars '()))
    (let ((char (read-char port)))
      (if (eof-object? char)
          (list->string (reverse! chars))
          (loop (cons char chars))))))

(define (read-file filename)
  (let* ((port (open-input-file filename))
         (string (read-all port)))
    (close-port port)
    string))

\f
;;;; Normal file ports.

;;; Write out an s-expression, and read it back.
(catch-test-errors
 (let ((string '("From fairest creatures we desire increase,"
                 "That thereby beauty's rose might never die,"))
       (filename (test-file)))
   (let ((port (open-output-file filename)))
     (write string port)
     (close-port port))
   (let ((port (open-input-file filename)))
     (let ((in-string (read port)))
       (pass-if "file: write and read back list of strings" 
                (equal? string in-string)))
     (close-port port))
   (delete-file filename)))
          
;;; Write out a string, and read it back a character at a time.
(catch-test-errors
 (let ((string "This is a test string\nwith no newline at the end")
       (filename (test-file)))
   (let ((port (open-output-file filename)))
     (display string port)
     (close-port port))
   (let ((in-string (read-file filename)))
     (pass-if "file: write and read back characters"
              (equal? string in-string)))
   (delete-file filename)))

;;; Buffered input/output port with seeking.
(catch-test-errors
 (let* ((filename (test-file))
        (port (open-file filename "w+")))
   (display "J'Accuse" port)
   (seek port -1 SEEK_CUR)
   (pass-if "file: r/w 1"
            (char=? (read-char port) #\e))
   (pass-if "file: r/w 2"
            (eof-object? (read-char port)))
   (seek port -1 SEEK_CUR)
   (write-char #\x port)
   (seek port 7 SEEK_SET)
   (pass-if "file: r/w 3"
            (char=? (read-char port) #\x))
   (seek port -2 SEEK_END)
   (pass-if "file: r/w 4"
            (char=? (read-char port) #\s))
   (delete-file filename)))

;;; Unbuffered input/output port with seeking.
(catch-test-errors
 (let* ((filename (test-file))
        (port (open-file filename "w+0")))
   (display "J'Accuse" port)
   (seek port -1 SEEK_CUR)
   (pass-if "file: ub r/w 1"
            (char=? (read-char port) #\e))
   (pass-if "file: ub r/w 2"
            (eof-object? (read-char port)))
   (seek port -1 SEEK_CUR)
   (write-char #\x port)
   (seek port 7 SEEK_SET)
   (pass-if "file: ub r/w 3"
            (char=? (read-char port) #\x))
   (seek port -2 SEEK_END)
   (pass-if "file: ub r/w 4"
            (char=? (read-char port) #\s))
   (delete-file filename)))

;;; Buffered output-only and input-only ports with seeking.
(catch-test-errors
 (let* ((filename (test-file))
        (port (open-output-file filename)))
   (display "J'Accuse" port)
   (pass-if "file: out tell"
            (= (seek port 0 SEEK_CUR) 8))
   (seek port -1 SEEK_CUR)
   (write-char #\x port)
   (close-port port)
   (let ((iport (open-input-file filename)))
     (pass-if "file: in tell 0"
              (= (seek iport 0 SEEK_CUR) 0))
     (read-char iport)
     (pass-if "file: in tell 1"
              (= (seek iport 0 SEEK_CUR) 1))
     (unread-char #\z iport)
     (pass-if "file: in tell 0 after unread"
              (= (seek iport 0 SEEK_CUR) 0))
     (pass-if "file: unread char still there"
              (char=? (read-char iport) #\z))
     (seek iport 7 SEEK_SET)
     (pass-if "file: in last char"
              (char=? (read-char iport) #\x))
     (close-port iport))
   (delete-file filename)))

;;; unusual characters.
(catch-test-errors
 (let* ((filename (test-file))
        (port (open-output-file filename)))
   (display (string #\nul (integer->char 255) (integer->char 128)
                    #\nul) port)
   (close-port port)
   (let* ((port (open-input-file filename))
          (line (read-line port)))
     (pass-if "file: read back NUL 1"
              (char=? (string-ref line 0) #\nul))
     (pass-if "file: read back 255"
              (char=? (string-ref line 1) (integer->char 255)))
     (pass-if "file: read back 128"
              (char=? (string-ref line 2) (integer->char 128)))
     (pass-if "file: read back NUL 2"
              (char=? (string-ref line 3) #\nul))
     (pass-if "file: EOF"
              (eof-object? (read-char port))))
   (delete-file filename)))

;;; line buffering mode.
(catch-test-errors 
 (let* ((filename (test-file))
        (port (open-file filename "wl"))
        (test-string "one line more or less"))
   (write-line test-string port)
   (let* ((in-port (open-input-file filename))
          (line (read-line in-port)))
     (close-port in-port)
     (close-port port)
     (pass-if "file: line buffering"
              (string=? line test-string)))
   (delete-file filename)))

;;; ungetting characters and strings.
(catch-test-errors
 (with-input-from-string "walk on the moon\nmoon"
                         (lambda ()
                           (read-char)
                           (unread-char #\a (current-input-port))
                           (pass-if "unread-char"
                                    (char=? (read-char) #\a))
                           (read-line)
                           (let ((replacenoid "chicken enchilada"))
                             (unread-char #\newline (current-input-port))
                             (unread-string replacenoid (current-input-port))
                             (pass-if "unread-string"
                                      (string=? (read-line) replacenoid)))
                           (pass-if "unread residue"
                                    (string=? (read-line) "moon")))))

;;; non-blocking mode on a port.  create a pipe and set O_NONBLOCK on
;;; the reading end.  try to read a byte: should get EAGAIN or
;;; EWOULDBLOCK error.
(catch-test-errors
 (let* ((p (pipe))
        (r (car p)))
   (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
   (pass-if "non-blocking-I/O"
            (catch 'system-error
                   (lambda () (read-char r) #f)
                   (lambda (key . args)
                     (and (eq? key 'system-error)
                          (let ((errno (car (list-ref args 3))))
                            (or (= errno EAGAIN)
                                (= errno EWOULDBLOCK)))))))))
\f
;;;; Pipe (popen) ports.

;;; Run a command, and read its output.
(catch-test-errors
 (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
        (in-string (read-all pipe)))
   (close-pipe pipe)
   (pass-if "pipe: read"
            (equal? in-string "Howdy there, partner!\n"))))

;;; Run a command, send some output to it, and see if it worked.
(catch-test-errors
 (let* ((filename (test-file))
        (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
   (display "Now Jimmy lives on a mushroom cloud\n" pipe)
   (display "Mommy, why does everybody have a bomb?\n" pipe)
   (close-pipe pipe)
   (let ((in-string (read-file filename)))
     (pass-if "pipe: write"
              (equal? in-string "Mommy, why does everybody have a bomb?\n")))
   (delete-file filename)))

\f
;;;; Void ports.  These are so trivial we don't test them.

\f
;;;; String ports.

(with-test-prefix "string ports"

  ;; Write text to a string port.
  (catch-test-errors
   (let* ((string "Howdy there, partner!")
          (in-string (call-with-output-string
                      (lambda (port)
                        (display string port)
                        (newline port)))))
     (pass-if "display text"
              (equal? in-string (string-append string "\n")))))
                   
  ;; Write an s-expression to a string port.
  (catch-test-errors
   (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
          (in-sexpr 
           (call-with-input-string (call-with-output-string
                                    (lambda (port)
                                      (write sexpr port)))
                                   read)))
     (pass-if "write/read sexpr"
              (equal? in-sexpr sexpr))))

  ;; seeking and unreading from an input string.
  (catch-test-errors
   (let ((text "that text didn't look random to me"))
     (call-with-input-string text
                             (lambda (p)
                               (pass-if "input tell 0"
                                        (= (seek p 0 SEEK_CUR) 0))
                               (read-char p)
                               (pass-if "input tell 1"
                                        (= (seek p 0 SEEK_CUR) 1))
                               (unread-char #\x p)
                               (pass-if "input tell back to 0"
                                        (= (seek p 0 SEEK_CUR) 0))
                               (pass-if "input ungetted char"
                                        (char=? (read-char p) #\x))
                               (seek p 0 SEEK_END)
                               (pass-if "input seek to end"
                                        (= (seek p 0 SEEK_CUR)
                                           (string-length text)))
                               (unread-char #\x p)
                               (pass-if "input seek to beginning"
                                        (= (seek p 0 SEEK_SET) 0))
                               (pass-if "input reread first char"
                                        (char=? (read-char p)
                                                (string-ref text 0)))))))
                                           
  ;; seeking an output string.
  (catch-test-errors
   (let* ((text "123456789")
          (len (string-length text))
          (result (call-with-output-string
                   (lambda (p)
                     (pass-if "output tell 0"
                              (= (seek p 0 SEEK_CUR) 0))
                     (display text p)
                     (pass-if "output tell end"
                              (= (seek p 0 SEEK_CUR) len))
                     (pass-if "output seek to beginning"
                              (= (seek p 0 SEEK_SET) 0))
                     (write-char #\a p)
                     (seek p -1 SEEK_END)
                     (pass-if "output seek to last char"
                              (= (seek p 0 SEEK_CUR)
                                 (- len 1)))
                     (write-char #\b p)))))
     (string-set! text 0 #\a)
     (string-set! text (- len 1) #\b)
     (pass-if "output check"
              (string=? text result)))))


\f
;;;; Soft ports.  No tests implemented yet.

\f
;;;; Generic operations across all port types.

(let ((port-loop-temp (test-file)))

  ;; Return a list of input ports that all return the same text.
  ;; We map tests over this list.
  (define (input-port-list text)
    
    ;; Create a text file some of the ports will use.
    (let ((out-port (open-output-file port-loop-temp)))
      (display text out-port)
      (close-port out-port))

    (list (open-input-file port-loop-temp)
          (open-input-pipe (string-append "cat " port-loop-temp))
          (call-with-input-string text (lambda (x) x))
          ;; We don't test soft ports at the moment.
          ))

  (define port-list-names '("file" "pipe" "string"))

  ;; Test the line counter.
  (define (test-line-counter text second-line final-column)
    (with-test-prefix "line counter"
      (let ((ports (input-port-list text)))
        (for-each
         (lambda (port port-name)
           (with-test-prefix port-name
             (pass-if "at beginning of input"
                      (= (port-line port) 0))
             (pass-if "read first character"
                      (eqv? (read-char port) #\x))
             (pass-if "after reading one character"
                      (= (port-line port) 0))
             (pass-if "read first newline"
                      (eqv? (read-char port) #\newline))
             (pass-if "after reading first newline char"
                      (= (port-line port) 1))
             (pass-if "second line read correctly"
                      (equal? (read-line port) second-line))
             (pass-if "read-line increments line number"
                      (= (port-line port) 2))
             (pass-if "read-line returns EOF"
                      (let loop ((i 0))
                        (cond
                         ((eof-object? (read-line port)) #t)
                         ((> i 20) #f)
                         (else (loop (+ i 1))))))
             (pass-if "line count is 5 at EOF"
                      (= (port-line port) 5))
             (pass-if "column is correct at EOF"
                      (= (port-column port) final-column))))
         ports port-list-names)
        (for-each close-port ports)
        (delete-file port-loop-temp))))

  (catch-test-errors
   (with-test-prefix "newline"
     (test-line-counter
      (string-append "x\n"
                     "He who receives an idea from me, receives instruction\n"
                     "himself without lessening mine; as he who lights his\n"
                     "taper at mine, receives light without darkening me.\n"
                     "  --- Thomas Jefferson\n")
      "He who receives an idea from me, receives instruction"
      0)))

  (catch-test-errors
   (with-test-prefix "no newline"
     (test-line-counter
      (string-append "x\n"
                     "He who receives an idea from me, receives instruction\n"
                     "himself without lessening mine; as he who lights his\n"
                     "taper at mine, receives light without darkening me.\n"
                     "  --- Thomas Jefferson\n"
                     "no newline here")
      "He who receives an idea from me, receives instruction"
      15))))

\f
;;;; testing read-delimited and friends

(with-test-prefix "read-delimited!"
  (let ((c (make-string 20 #\!)))
    (call-with-input-string 
     "defdef\nghighi\n"
     (lambda (port)
       
       (read-delimited! "\n" c port 'concat)
       (pass-if "read-delimited! reads a first line"
                (string=? c "defdef\n!!!!!!!!!!!!!"))

       (read-delimited! "\n" c port 'concat 3)
       (pass-if "read-delimited! reads a first line"
                (string=? c "defghighi\n!!!!!!!!!!"))))))

\f
;;;; char-ready?

(call-with-input-string
 "howdy"
 (lambda (port)
   (pass-if "char-ready? returns true on string port"
            (char-ready? port))))

;;; This segfaults on some versions of Guile.  We really should run
;;; the tests in a subprocess...

(call-with-input-string
 "howdy"
 (lambda (port)
   (with-input-from-port
       port
     (lambda ()
       (pass-if "char-ready? returns true on string port as default port"
                (char-ready?))))))

\f
;;;; Close current-input-port, and make sure everyone can handle it.

(with-test-prefix "closing current-input-port"
  (for-each (lambda (procedure name)
              (with-input-from-port
                  (call-with-input-string "foo" (lambda (p) p))
                (lambda ()
                  (close-port (current-input-port))
                  (pass-if name
                           (signals-error? 'wrong-type-arg (procedure))))))
            (list read read-char read-line)
            '("read" "read-char" "read-line")))