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