1 ;;;; popen.test --- exercise ice-9/popen.scm -*- scheme -*-
3 ;;;; Copyright 2003, 2006 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 2.1 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (define-module (test-suite test-ice-9-popen)
20 #:use-module (test-suite lib)
21 #:use-module (ice-9 popen))
24 ;; read from PORT until eof is reached, return what's read as a string
25 (define (read-string-to-eof port)
26 (do ((lst '() (cons c lst))
27 (c (read-char port) (read-char port)))
29 (list->string (reverse! lst)))))
31 ;; call (THUNK), with SIGPIPE set to SIG_IGN so that an EPIPE error is
32 ;; generated rather than a SIGPIPE signal
33 (define (with-epipe thunk)
36 (sigaction SIGPIPE SIG_IGN))
45 (with-test-prefix "open-input-pipe"
47 (pass-if-exception "no args" exception:wrong-num-args
51 (port? (open-input-pipe "echo hello")))
54 (string=? "hello\n" (read-string-to-eof (open-input-pipe "echo hello"))))
56 ;; exercise file descriptor setups when stdin is the same as stderr
57 (pass-if "stdin==stderr"
58 (let ((port (open-file "/dev/null" "r+")))
59 (with-input-from-port port
61 (with-error-to-port port
63 (open-input-pipe "echo hello"))))))
66 ;; exercise file descriptor setups when stdout is the same as stderr
67 (pass-if "stdout==stderr"
68 (let ((port (open-file "/dev/null" "r+")))
69 (with-output-to-port port
71 (with-error-to-port port
73 (open-input-pipe "echo hello"))))))
76 ;; After the child closes stdout (which it indicates here by writing
77 ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4 and
78 ;; earlier a duplicate of stdout existed in the child, meaning eof was not
80 (pass-if "no duplicate"
82 (port (with-error-to-port (cdr pair)
85 "exec 1>/dev/null; echo closed 1>&2; sleep 999")))))
86 (read-char (car pair)) ;; wait for child to do its thing
87 (and (char-ready? port)
88 (eof-object? (read-char port))))))
94 (with-test-prefix "open-output-pipe"
96 (pass-if-exception "no args" exception:wrong-num-args
100 (port? (open-output-pipe "exit 0")))
102 ;; exercise file descriptor setups when stdin is the same as stderr
103 (pass-if "stdin==stderr"
104 (let ((port (open-file "/dev/null" "r+")))
105 (with-input-from-port port
107 (with-error-to-port port
109 (open-output-pipe "exit 0"))))))
112 ;; exercise file descriptor setups when stdout is the same as stderr
113 (pass-if "stdout==stderr"
114 (let ((port (open-file "/dev/null" "r+")))
115 (with-output-to-port port
117 (with-error-to-port port
119 (open-output-pipe "exit 0"))))))
122 ;; After the child closes stdin (which it indicates here by writing
123 ;; "closed" to stderr), the parent should see a broken pipe. We setup to
124 ;; see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4 and earlier a
125 ;; duplicate of stdin existed in the child, preventing the broken pipe
127 (pass-if "no duplicate"
131 (port (with-error-to-port (cdr pair)
134 "exec 0</dev/null; echo closed 1>&2; sleep 999")))))
135 (read-char (car pair)) ;; wait for child to do its thing
138 (write-char #\x port)
141 (lambda (key name fmt args errno-list)
142 (= (car errno-list) EPIPE))))))))
148 (with-test-prefix "close-pipe"
150 (pass-if-exception "no args" exception:wrong-num-args
154 (let ((st (close-pipe (open-output-pipe "exit 0"))))
155 (and (status:exit-val st)
156 (= 0 (status:exit-val st)))))
159 (let ((st (close-pipe (open-output-pipe "exit 1"))))
160 (and (status:exit-val st)
161 (= 1 (status:exit-val st))))))