guile/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, 2001, 2004, 2006, 2007 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., 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))

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

(define (test-file)
  (data-file-name "ports-test.tmp"))


;;;; 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))


;;;; Normal file ports.

;;; Write out an s-expression, and read it back.
(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.
(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.
(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))
  (close-port port)
  (delete-file filename))

;;; Unbuffered input/output port with seeking.
(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))
  (close-port port)
  (delete-file filename))

;;; Buffered output-only and input-only ports with seeking.
(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.
(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)))
    (close-port port))
  (delete-file filename))

;;; line buffering mode.
(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.
(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.
(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))))))))


;;;; Pipe (popen) ports.

;;; Run a command, and read its output.
(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.
(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))

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


;;;; String ports.

(with-test-prefix "string ports"

  ;; Write text to a string port.
  (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.
  (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.
  (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.
  (let* ((text (string-copy "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))))

(with-test-prefix "call-with-output-string"

  ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
  ;; occur.
  (pass-if-exception "proc closes port" exception:wrong-type-arg
    (call-with-output-string close-port)))


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


;;;; 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))))

  (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))

  (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)))

;; Test port-line and port-column for output ports

(define (test-output-line-counter text final-column)
  (with-test-prefix "port-line and port-column for output ports"
    (let ((port (open-output-string)))
      (pass-if "at beginning of input"
	       (and (= (port-line port) 0)
		    (= (port-column port) 0)))
      (write-char #\x port)
      (pass-if "after writing one character"
	       (and (= (port-line port) 0)
		    (= (port-column port) 1)))
      (write-char #\newline port)
      (pass-if "after writing first newline char"
	       (and (= (port-line port) 1)
		    (= (port-column port) 0)))
      (display text port)
      (pass-if "line count is 5 at end"
	       (= (port-line port) 5))
      (pass-if "column is correct at end"
	       (= (port-column port) final-column)))))

(test-output-line-counter
 (string-append "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")
 15)

(with-test-prefix "port-column"

  (with-test-prefix "output"

    (pass-if "x"
      (let ((port (open-output-string)))
	(display "x" port)
	(= 1 (port-column port))))

    (pass-if "\\a"
      (let ((port (open-output-string)))
	(display "\a" port)
	(= 0 (port-column port))))

    (pass-if "x\\a"
      (let ((port (open-output-string)))
	(display "x\a" port)
	(= 1 (port-column port))))

    (pass-if "\\x08 backspace"
      (let ((port (open-output-string)))
	(display "\x08" port)
	(= 0 (port-column port))))

    (pass-if "x\\x08 backspace"
      (let ((port (open-output-string)))
	(display "x\x08" port)
	(= 0 (port-column port))))

    (pass-if "\\n"
      (let ((port (open-output-string)))
	(display "\n" port)
	(= 0 (port-column port))))

    (pass-if "x\\n"
      (let ((port (open-output-string)))
	(display "x\n" port)
	(= 0 (port-column port))))

    (pass-if "\\r"
      (let ((port (open-output-string)))
	(display "\r" port)
	(= 0 (port-column port))))

    (pass-if "x\\r"
      (let ((port (open-output-string)))
	(display "x\r" port)
	(= 0 (port-column port))))

    (pass-if "\\t"
      (let ((port (open-output-string)))
	(display "\t" port)
	(= 8 (port-column port))))

    (pass-if "x\\t"
      (let ((port (open-output-string)))
	(display "x\t" port)
	(= 8 (port-column port)))))

  (with-test-prefix "input"

    (pass-if "x"
      (let ((port (open-input-string "x")))
	(while (not (eof-object? (read-char port))))
	(= 1 (port-column port))))

    (pass-if "\\a"
      (let ((port (open-input-string "\a")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "x\\a"
      (let ((port (open-input-string "x\a")))
	(while (not (eof-object? (read-char port))))
	(= 1 (port-column port))))

    (pass-if "\\x08 backspace"
      (let ((port (open-input-string "\x08")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "x\\x08 backspace"
      (let ((port (open-input-string "x\x08")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "\\n"
      (let ((port (open-input-string "\n")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "x\\n"
      (let ((port (open-input-string "x\n")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "\\r"
      (let ((port (open-input-string "\r")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "x\\r"
      (let ((port (open-input-string "x\r")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "\\t"
      (let ((port (open-input-string "\t")))
	(while (not (eof-object? (read-char port))))
	(= 8 (port-column port))))

    (pass-if "x\\t"
      (let ((port (open-input-string "x\t")))
	(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)))))

;;;
;;; 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"
    (throw 'unresolved)
    (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))))))

;;;
;;; 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

(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!!!!!!!!!!"))))))


;;;; 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?))))))


;;;; 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-exception name
		    exception:wrong-type-arg
		    (procedure)))))
	    (list read read-char read-line)
	    '("read" "read-char" "read-line")))

(delete-file (test-file))