;;;; popen.test --- exercise ice-9/popen.scm -*- scheme -*- ;;;; ;;;; Copyright 2003, 2006, 2010, 2011, 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 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 ;;;; Lesser General Public License for more details. ;;;; ;;;; 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-ice-9-popen) #:use-module (test-suite lib)) ;; read from PORT until eof is reached, return what's read as a string (define (read-string-to-eof port) (do ((lst '() (cons c lst)) (c (read-char port) (read-char port))) ((eof-object? c) (list->string (reverse! lst))))) ;; call (THUNK), with SIGPIPE set to SIG_IGN so that an EPIPE error is ;; generated rather than a SIGPIPE signal (define (with-epipe thunk) (dynamic-wind (lambda () (sigaction SIGPIPE SIG_IGN)) thunk restore-signals)) (define-syntax-rule (if-supported body ...) (if (provided? 'fork) (begin body ...))) (if-supported (use-modules (ice-9 popen)) ;; ;; open-input-pipe ;; (with-test-prefix "open-input-pipe" (pass-if-exception "no args" exception:wrong-num-args (open-input-pipe)) (pass-if "port?" (port? (open-input-pipe "echo hello"))) (pass-if "echo hello" (string=? "hello\n" (read-string-to-eof (open-input-pipe "echo hello")))) ;; exercise file descriptor setups when stdin is the same as stderr (pass-if "stdin==stderr" (let ((port (open-file "/dev/null" "r+"))) (with-input-from-port port (lambda () (with-error-to-port port (lambda () (open-input-pipe "echo hello")))))) #t) ;; exercise file descriptor setups when stdout is the same as stderr (pass-if "stdout==stderr" (let ((port (open-file "/dev/null" "r+"))) (with-output-to-port port (lambda () (with-error-to-port port (lambda () (open-input-pipe "echo hello")))))) #t) (pass-if "open-input-pipe process gets (current-input-port) as stdin" (let* ((p2c (pipe)) (port (with-input-from-port (car p2c) (lambda () (open-input-pipe "read line && echo $line"))))) (display "hello\n" (cdr p2c)) (force-output (cdr p2c)) (let ((result (eq? (read port) 'hello))) (close-port (cdr p2c)) (close-pipe port) result))) ;; After the child closes stdout (which it indicates here by writing ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4 ;; and earlier a duplicate of stdout existed in the child, meaning ;; eof was not seen. ;; ;; Note that the objective here is to test that the parent sees EOF ;; while the child is still alive. (It is obvious that the parent ;; must see EOF once the child has died.) The use of the `p2c' ;; pipe, and `echo closed' and `read' in the child, allows us to be ;; sure that we are testing what the parent sees at a point where ;; the child has closed stdout but is still alive. (pass-if "no duplicate" (let* ((c2p (pipe)) (p2c (pipe)) (port (with-error-to-port (cdr c2p) (lambda () (with-input-from-port (car p2c) (lambda () (open-input-pipe "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; read REPLY"))))))) (close-port (cdr c2p)) ;; write side (let ((result (eof-object? (read-char port)))) (display "hello!\n" (cdr p2c)) (force-output (cdr p2c)) (close-pipe port) result)))) ;; ;; open-output-pipe ;; (with-test-prefix "open-output-pipe" (pass-if-exception "no args" exception:wrong-num-args (open-output-pipe)) (pass-if "port?" (port? (open-output-pipe "exit 0"))) ;; exercise file descriptor setups when stdin is the same as stderr (pass-if "stdin==stderr" (let ((port (open-file "/dev/null" "r+"))) (with-input-from-port port (lambda () (with-error-to-port port (lambda () (open-output-pipe "exit 0")))))) #t) ;; exercise file descriptor setups when stdout is the same as stderr (pass-if "stdout==stderr" (let ((port (open-file "/dev/null" "r+"))) (with-output-to-port port (lambda () (with-error-to-port port (lambda () (open-output-pipe "exit 0")))))) #t) ;; After the child closes stdin (which it indicates here by writing ;; "closed" to stderr), the parent should see a broken pipe. We ;; setup to see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4 ;; and earlier a duplicate of stdin existed in the child, preventing ;; the broken pipe occurring. ;; ;; Note that the objective here is to test that the parent sees a ;; broken pipe while the child is still alive. (It is obvious that ;; the parent will see a broken pipe once the child has died.) The ;; use of the `c2p' pipe, and the repeated `echo closed' in the ;; child, allows us to be sure that we are testing what the parent ;; sees at a point where the child has closed stdin but is still ;; alive. ;; ;; Note that `with-epipe' must apply only to the parent and not to ;; the child process; we rely on the child getting SIGPIPE, to ;; terminate it (and avoid leaving a zombie). (pass-if "no duplicate" (let* ((c2p (pipe)) (port (with-error-to-port (cdr c2p) (lambda () (open-output-pipe (string-append "exec guile --no-auto-compile -s \"" (getenv "TEST_SUITE_DIR") "/tests/popen-child.scm\"")))))) (close-port (cdr c2p)) ;; write side (with-epipe (lambda () (let ((result (and (char? (read-char (car c2p))) ;; wait for child to do its thing (catch 'system-error (lambda () (write-char #\x port) (force-output port) #f) (lambda (key name fmt args errno-list) (= (car errno-list) EPIPE)))))) ;; Now close our reading end of the pipe. This should give ;; the child a broken pipe and so allow it to exit. (close-port (car c2p)) (close-pipe port) result)))))) ;; ;; close-pipe ;; (with-test-prefix "close-pipe" (pass-if-exception "no args" exception:wrong-num-args (close-pipe)) (pass-if "exit 0" (let ((st (close-pipe (open-output-pipe "exit 0")))) (and (status:exit-val st) (= 0 (status:exit-val st))))) (pass-if "exit 1" (let ((st (close-pipe (open-output-pipe "exit 1")))) (and (status:exit-val st) (= 1 (status:exit-val st)))))))