guile/test-suite/tests/popen.test

;;;; popen.test --- exercise ice-9/popen.scm      -*- scheme -*-
;;;;
;;;; Copyright 2003, 2006, 2010, 2011, 2013, 2014, 2020
;;;;           2021 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)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 rdelim))


(define mingw?
  (string-contains %host-type "-mingw32"))

;; 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 ...)
  (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"
     (when mingw? (throw 'unresolved))
     (let* ((c2p (pipe))
            (p2c (pipe))
            (port (with-error-to-port (cdr c2p)
                    (lambda ()
                      (with-input-from-port (car p2c)
                        (lambda ()
                          (open-input-pipe
                           (format #f "exec 1>~a; echo closed 1>&2; \
exec 2>~a; read REPLY"
                                   %null-device %null-device))))))))
       (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))))))


 (with-test-prefix "open-pipe*"

   (pass-if-equal "OPEN_BOTH"
       '(0 (good!))
     ;; This test ensures that the ports that underlie the read/write
     ;; port are unbuffered.  If they were buffered, the child process
     ;; would wait in 'read' forever.
     (let ((pipe (open-pipe* OPEN_BOTH "guile" "-c"
                             (object->string
                              '(begin
                                 (setvbuf (current-output-port) 'line)
                                 (write '(hello!))
                                 (newline)
                                 (let ((greeting (read)))
                                   (write '(good!))))))))
       (setvbuf pipe 'line)
       (let ((return (read pipe)))
         (write '(hi!) pipe)
         (newline pipe)
         (let ((last (read pipe)))
           (list (close-pipe pipe) last))))))

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


;;
;; pipeline related tests
;;

(pass-if-equal "open-process"
    '("HELLO WORLD" 0)
  (receive (from to pid)
      ((@@ (ice-9 popen) open-process) OPEN_BOTH
       "tr" "[:lower:]" "[:upper:]")
    (display "hello world" to) (close to)
    (list (read-string from)
          (status:exit-val (cdr (waitpid pid))))))

(pass-if-equal "piped-process"
    42
  (status:exit-val
   (cdr (waitpid ((@@ (ice-9 popen) piped-process)
                  "./meta/guile" '("-c" "(exit 42)"))))))

(pass-if-equal "piped-process: with output"
    '("foo bar\n" 0)
  (let* ((p (pipe))
         (pid ((@@ (ice-9 popen) piped-process) "echo" '("foo" "bar")
               (cons (port->fdes (car p))
                     (port->fdes (cdr p))))))
    (list (read-string (car p))
          (status:exit-val (cdr (waitpid pid))))))

(pass-if-equal "pipeline"
    '("HELLO WORLD\n" (0 0))
  (receive (from to pids)
      (pipeline '(("echo" "hello world")
                  ("tr" "[:lower:]" "[:upper:]")))
    (list (read-string from)
          (map (compose status:exit-val cdr waitpid) pids))))