(module scsh-tests ()
(import scheme)
(cond-expand
(chicken-5 (import (chicken base) (chicken port) (chicken condition)
(chicken io) (chicken file) (chicken file posix)
(chicken process signal)
(chicken fixnum) ;; Why is this needed?!
srfi-18 test)
#;(include "../scsh-process.scm")
(import scsh-process)
(define (read-all #!optional file-or-port)
(cond ((string? file-or-port)
(with-input-from-file file-or-port read-string))
(file-or-port (read-string #f file-or-port))
(else (read-string))))
)
(else (import chicken)
#;(include "../scsh-process.scm")
(use scsh-process)
(use test utils extras ports files posix
srfi-13 srfi-18 (only setup-api version>=?))))
(test-begin "scsh-process")
(test-group "Procedural interface"
(test "Fork/pipe \"hello world\" example from SCSH reference manual"
'(0 #t "Hello, world.")
(receive (exit-status exited-ok? pid)
(wait (fork/pipe
(lambda ()
(with-output-to-port (open-output-file* 1)
(lambda () (display "Hello, world.\n"))))))
(list exit-status exited-ok? (read-line (open-input-file* 0)))))
(test "run/string* returns a string output in a subprocess"
"This is a test"
(run/string* (lambda () (display "This is a test"))))
;; Ensure all processes up to here have been reaped
(handle-exceptions exn (void) (let lp () (when (wait #f) (lp))))
;; We must mask sigchld, because otherwise our next (wait #f) will
;; fail due to scsh-process' signal handler possibly reaping the
;; child before our wait is able to do so.
(signal-mask! signal/chld)
(test "wait for next process to exit"
'(#t #t #t)
(let ((p (& (sleep 1))))
(receive (status ok? pid) (wait #f)
(receive (status2 ok?2 pid2) (wait p)
(list (eq? status status2) (eq? ok? ok?2) (or (eq? pid pid2) (list pid pid2)))))))
(test-assert "signal wasn't unmasked" (signal-masked? signal/chld))
(test "sigchld is masked inside child process"
"yes"
(run/string*
(lambda ()
(display (if (signal-masked? signal/chld) "yes" "no")))))
(signal-unmask! signal/chld)
(test "after unmasking, sigchld is also unmasked inside child process"
"yes"
(run/string*
(lambda ()
(display (if (signal-masked? signal/chld) "no" "yes")))))
;; Reported by Haochi Kiang
(test "run/string* does not redirect stderr"
'("This should go to stdout" "")
(let* ((strerr (open-output-string))
(ignored-output ; Collected in child process
(with-error-output-to-port
strerr
(lambda ()
(run/string*
(lambda ()
(display "This should go to stdout")
;; This doesn't end up in the parent process'
;; buffer because the memory isn't shared.
(display "This should go to stderr"
(current-error-port))))))))
(list ignored-output (get-output-string strerr)))))
(test-group "Macro (EPF) interface"
(delete-file* "outfile") ; Leftovers from last run
(test-group "Various run/... forms"
(test "Simple run/string"
"hi, there\n"
(run/string (echo "hi, there")))
;; Reported by Haochi Kiang
(test "Simple run/string with output to stderr"
""
;; TODO: Find some way so this doesn't pollute the actual
;; process's stderr
(run/string (sh -c "echo 'hi, there' >&2")))
;; Reported by Diego "dieggsy"
(test "Simple run/string and stderr dup()ed to stdout"
"hi, there\n"
(run/string (sh -c "echo 'hi, there' >&2") (= 2 1)))
(test "Unquote-splicing run/string"
"hi, there\n"
(run/string (echo ,@(list "hi," "there"))))
(test "Simple run/sexp"
'("hi, there")
(run/sexp (echo "(\"hi, there\") trailing stuff is ignored")))
(test "Simple run/sexps"
'(("hi, there") (a b c))
(run/sexps (echo "(\"hi, there\") (a b c)")))
(test "Simple run/port"
'(a b c)
(read (run/port (echo "(a b c)"))))
(let ((tmpfile (run/file (echo "blah"))))
(test "Simple run/file"
"blah\n"
(with-input-from-file tmpfile read-all))
(test "Appending to a file"
'("blah" "foo")
(begin (run (echo foo) (>> ,tmpfile))
(with-input-from-file tmpfile read-lines)))
(let ((message "testing, 1 2 3"))
(test "Redirecting from object"
`("blah" "foo" ,"esing, 1 2 3")
(run/strings (pipe (epf (tr -d t) (<< ,message))
(cat ,tmpfile -)))))
(delete-file* tmpfile)))
(test-group "Subprocesses"
(test "run/string with begin form"
"hi, there\n"
(run/string (pipe (begin (print "hi, there")) (cat))))
(when (cond-expand
(chicken-5 #t)
(else (version>=? (chicken-version) "4.8.1")))
(let ((child? #f))
(thread-start! (lambda ()
(thread-sleep! 0.5)
(when child? (print "haihai"))))
(test "Simple 'begin' form with threading"
"hi, there\n"
(run/string (pipe (begin (set! child? #t)
(thread-sleep! 1)
(print "hi, there"))
(cat))))))
(let ((the-outfile "outfile"))
(test "Subprocess writing to a file"
"hi, there\n"
(begin (run (echo "hi, there") (> ,the-outfile))
(read-all the-outfile)))
(test "Appending to the file"
"hi, there\nhi, again\n"
(begin (run (echo "hi, again") (>> ,the-outfile))
(read-all the-outfile)))
(test "Writing to the file truncates"
"hi, truncated\n"
(begin (run (echo "hi, truncated") (> ,the-outfile))
(read-all the-outfile))))
(delete-file* "outfile")
(let ((echo-command 'echo))
(test "Subprocess piped to another process, writing to a file"
"1235\n"
(begin (run (pipe (,echo-command "1234" + 1)
("sh" -c "read foo; echo $(($foo))"))
(> outfile))
(read-all "outfile"))))
(delete-file* "outfile")
;; Reported by Haochi Kiang
(test "Output redirection with pipe ignores stderr"
""
;; TODO: Find some way so this doesn't pollute the actual
;; process's stderr
(run/string (pipe (sh -c "echo foo >&2") (cat))))
(test "Nested output redirection with pipe+"
"foo\n"
(run/string (pipe+ ((1 0))
(pipe+ ((2 0)) (sh -c "echo foo >&2") (cat))
(cat))))
(test "Collecting FDs"
(list 0 "foo\n" "bar\n")
(receive (status port1 port2)
(run/collecting (2 1) (sh -c "echo foo >&2; echo bar"))
(list status (read-all port1) (read-all port2)))))
(test-group "Conditional process sequencing forms"
(test "&& runs for all true values"
(list #t "bar\n")
(list (&& (epf (echo "foo") (> outfile))
(true)
(epf (echo "bar") (> outfile)))
(read-all "outfile")))
(delete-file* "outfile")
(test "&& stops at first false value and returns false"
(list #f "foo\n")
(list (&& (epf (echo "foo") (> outfile))
(false)
(epf (echo "bar") (> outfile)))
(read-all "outfile")))
(delete-file* "outfile")
(test "|| stops at first true value and returns true"
(list #t "foo\n")
(list (|| (epf (echo "foo") (> outfile))
(true)
(epf (echo "bar") (> outfile)))
(read-all "outfile")))
(delete-file* "outfile")
(test "|| continues after first false value and returns true"
(list #t "bar\n")
(list (|| (false)
(epf (echo "bar") (> outfile)))
(read-all "outfile")))
(delete-file* "outfile")
(test "|| continues beyond all false values and returns false"
#f
(|| (false) (epf (sh -c "echo hi && false") (- 1))))))
(test-group "finalization"
;; TODO: Find a way to test that the input port didn't get replaced by
;; one from a subshell. This happened before, but not sure how
;; to detect this except running it manually from the REPL.
(test-error "No more zombies lying around after we're done" (wait)))
(test-end)
(test-exit)
)