;;; subprocess.scm

;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005,
;;   2006, 2007, 2009, 2010, 2011, 2012 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Code:

(define-module (ttn-do zzz subprocess)
  #:export (shell-quote-argument
            system*
            sysfmt
            find-program
            args->normalized-list
            call-process
            call-process->buffers
            make-buffered-caller
            shell-command->string
            fshell-command->string
            shell-command->list
            port-lines
            file-lines)
  #:use-module ((srfi srfi-13) #:select (string-join
                                         string-tokenize
                                         string-concatenate
                                         substring/shared))
  #:use-module ((srfi srfi-14) #:select (char-set-complement char-set))
  #:use-module ((ice-9 regex) #:select (match:start))
  #:use-module ((ice-9 optargs-kw) #:select (lambda*
                                             define*
                                             let-optional*
                                             let-keywords*))
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module ((ice-9 popen) #:select (open-input-pipe
                                        close-pipe))
  #:use-module ((ttn-do mogrify) #:select (editing-buffer-manager
                                           editing-buffer))
  #:use-module ((ttn-do zzz filesystem) #:select (safe-rewind
                                                  temporary-file-port))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  fs)))

(define *not-space* (char-set-complement (char-set #\space)))

;; Quote @var{arg} for passing as argument to an inferior shell.
;;
(define shell-quote-argument
  (let ((need-backslash (make-regexp "[^-0-9a-zA-Z_./]")))
    (lambda (arg)
      (define (sub b e)
        (substring/shared arg b e))
      (let ((acc (accumulator)))
        (let loop ((start 0))
          (cond ((= start (string-length arg)))
                ((regexp-exec need-backslash arg start)
                 => (lambda (m)
                      (let ((pos (match:start m)))
                        (acc (sub start pos) "\\" (sub pos (1+ pos)))
                        (loop (1+ pos)))))
                (else
                 (acc (sub start (1+ start)))
                 (loop (1+ start)))))
        (string-concatenate (acc))))))

(define (split/space s)
  (string-tokenize s *not-space*))

(define (join/space ls)
  (string-join ls " "))

(define *not-colon* (char-set-complement (char-set #\:)))

(define (split/colon s)
  (string-tokenize s *not-colon*))

(define (join/colon ls)
  (string-join ls ":"))

;; Echo @var{args} to make a string and pass it to @code{system}.
;;
(define (system* . args)
  (system (join/space args)))

;; Apply @code{simple-format} to @var{args} and pass to @code{system}.
;; The @sc{car} of @var{args} is the format string.
;;
(define (sysfmt . args)
  (system (apply fs (car args) (cdr args))))

;; Search env var @code{PATH} for executable program @var{name}.
;; If found, return the absolute name, otherwise @code{#f}.
;;
(define (find-program name)
  (let ((full (search-path (split/colon (or (getenv "PATH") ".")) name)))
    (and full (access? full X_OK)) full))

;; For @var{args}, trim surrounding whitespace, join together separated by
;; space, then split apart on space boundaries.  For example:
;;
;; @example
;; (args->normalized-list "rsync a b c"
;;                        " d "
;;                        "e"
;;                        "f g h")
;; @result{} ("rsync" "a" "b" "c" "d" "e" "f" "g" "h")
;; @end example
;;
(define (args->normalized-list . args)
  (split/space (join/space args)))

;; Call @var{program} synchronously in separate process.
;; Unless given @code{#:outp 0}, wait for @var{program}
;; to terminate and return a numeric exit status.
;;
;; @table @code
;; @item #:inp (current-input-port)
;; Input port.  @code{#f} means @file{/dev/null}.
;;
;; @item #:outp (current-output-port)
;; Output port.  @code{#f} means discard output; 0 (zero) means discard,
;; don't wait for @var{program} to terminate, and return @code{#f}.
;;
;; @item #:errp (current-error-port)
;; Error output port.  @code{#f} means discard output.
;;
;; @item #:norm #f
;; Non-@code{#f} means @var{program} and @var{args} should be passed
;; through @code{args->normalized-list}.
;;
;; @item #:args ()
;; List of additional args to pass to @var{program}.
;; @end table
;;
(define* (call-process program
                       #:key
                       (inp (current-input-port))
                       (outp (current-output-port))
                       (errp (current-error-port))
                       (norm #f)
                       (args ()))
  ;; runtime system check
  (or (defined? 'close-all-fdes-except)
      (defined? 'port-for-each)
      (error "sorry, ‘call-process’ unusable"))
  ;; simple type check
  (let ((chk (lambda (p)
               (or (not p)
                   (port? p)
                   (error "not a port:" p)))))
    (chk inp)
    (or (and (number? outp) (zero? outp)) (chk outp))
    (chk errp))
  ;; ok, continue
  (and norm
       (let ((ls (apply args->normalized-list program args)))
         (set! program (car ls))
         (set! args (cdr ls))))
  (let* ((null-input? (not inp))
         (async? (equal? 0 outp))
         (discard-output? (or async? (not outp)))
         (discard-error-output? (or async? (not errp)))
         (ensure-fdes (lambda (ignore? port mode)
                        (if ignore?
                            (open-fdes *null-device* mode)
                            (or (false-if-exception (fileno port))
                                (open-fdes *null-device* mode))))))
    (let ((pid (primitive-fork)))
      (flush-all-ports)
      (cond ((zero? pid)
             ;; child -- this section snarfed from popen.scm ‘open-process’
             ;;          and modified to not worry about pipes
             (set-batch-mode?! #t)
             ;; select the three file descriptors to be used as
             ;; standard descriptors 0, 1, 2 for the new process.
             (let ((input-fdes (ensure-fdes null-input? inp O_RDONLY))
                   (output-fdes (ensure-fdes discard-output? outp O_WRONLY))
                   (error-fdes (ensure-fdes discard-error-output?
                                            errp O_WRONLY)))
               ;; close all file descriptors in ports inherited from the
               ;; parent except for the three selected above.  this is to
               ;; avoid causing problems for other pipes in the parent.  use
               ;; low-level system calls, not close-port or the scsh routines,
               ;; to avoid side-effects such as flushing port buffers or
               ;; evicting ports.
               (let ((c-a-f-e (if (defined? 'close-all-fdes-except)
                                  close-all-fdes-except
                                  (lambda ok
                                    (port-for-each
                                     (lambda (pt-entry)
                                       (false-if-exception
                                        (let ((fd (fileno pt-entry)))
                                          (or (memq fd ok)
                                              (close-fdes fd))))))))))
                 (c-a-f-e input-fdes
                          output-fdes
                          error-fdes))
               ;; copy the three selected descriptors to the standard
               ;; descriptors 0, 1, 2.  note that it's possible that
               ;; output-fdes or input-fdes is equal to error-fdes.
               (cond ((not (= input-fdes 0))
                      (if (= output-fdes 0)
                          (set! output-fdes (dup->fdes 0)))
                      (if (= error-fdes 0)
                          (set! error-fdes (dup->fdes 0)))
                      (dup2 input-fdes 0)))
               (cond ((not (= output-fdes 1))
                      (if (= error-fdes 1)
                          (set! error-fdes (dup->fdes 1)))
                      (dup2 output-fdes 1)))
               (dup2 error-fdes 2)
               (apply execlp program program args)
               (alfksdlkajdlkfaldskjf)  ; should never get here
               ))
            (else
             ;; parent
             (if async?
                 #f
                 (cdr (waitpid pid))))))))

(define (read/cleanup-tmpfile port buf)
  (safe-rewind port)
  (editing-buffer buf
    (insert port)))

;; Call @var{program} synchronously in separate process.
;; Return a numeric exit status.  Keywords are:
;;
;; @table @code
;; @item #:inb #f
;; Input buffer.
;;
;; @item #:outb #f
;; Output buffer
;;
;; @item #:errb #f
;; Error output buffer.
;;
;; @item #:norm #f
;; Non-@code{#f} means that @var{program} and @var{args} should be
;; passed through @code{args->normalized-list}.
;;
;; @item #:args ()
;; List of additional args to pass to @var{program}.
;; @end table
;;
(define* (call-process->buffers program
                                #:key
                                (inb #f) (outb #f) (errb #f)
                                (norm #f) (args ()))
  (and norm
       (let ((ls (apply args->normalized-list program args)))
         (set! program (car ls))
         (set! args (cdr ls))))
  (let ((in-port (and inb (let ((p (temporary-file-port)))
                            (editing-buffer inb
                              (write-to-port p))
                            (safe-rewind p)
                            p)))
        (out-port (and outb (temporary-file-port)))
        (err-port (and errb (temporary-file-port))))
    (let ((rv (call-process program
                            #:inp in-port
                            #:outp out-port
                            #:errp err-port
                            #:args args)))
      (and outb (read/cleanup-tmpfile out-port outb))
      (and errb (read/cleanup-tmpfile err-port errb))
      rv)))

;; Return a procedure capable of calling @var{program}.
;; When called, the program stdout and stderr are captured to buffers.
;; The key @code{#:inb} (default #f) specifies an input buffer to use
;; for the call.  The key @code{#:args} (default the empty list) specifies
;; additional args to pass.
;;
;; The returned procedure takes one of the following commands (either a
;; keyword or similarly-named symbol):
;;
;; @table @code
;; @item #:redefine NEW-DEF
;; Redefine the called program and its args.
;; @var{new-def} is one or more strings.
;;
;; @item #:execute
;; Call program, clearing buffers first.
;; Return raw exit status of the program.
;; See @code{status:exit-val} for more info.
;;
;; @item #:execute/no-init
;; Same as @code{#:execute}, but do not clear buffers first.
;;
;; @item #:outbuf
;; Return output buffer object.
;;
;; @item #:outbuf-string
;; Return output buffer as a string.
;;
;; @item #:outbuf-lines
;; Return output buffer as a list of strings.
;;
;; @item #:errbuf
;; Return error output buffer.
;;
;; @item #:errbuf-string
;; Return error output buffer as a string.
;;
;; @item #:errbuf-lines
;; Return error output buffer as a list of strings.
;;
;; @item #:exit-val
;; Return exit status from the last execution.
;; Signal an error if @code{#:execute} (or @code{#:execute/no-init})
;; command has not yet been issued since closure creation
;; or most recent @code{#:redefine}.
;; @end table
;;
;; The @code{#:outbuf-lines} and @code{#:errbuf-lines} commands
;; use newline to separate.
;;
(define* (make-buffered-caller program #:key (inb #f) (args ()))
  (let* ((outbuf (editing-buffer-manager))
         (errbuf (editing-buffer-manager))
         (not-yet #t)
         (exit-val #f)
         (do-it!-proc (lambda (program . args)
                        (set! not-yet #t)
                        (lambda ()
                          (set! not-yet #f)
                          (set! exit-val
                                (call-process->buffers
                                 program
                                 #:inb inb
                                 #:outb (outbuf outbuf)
                                 #:errb (errbuf errbuf)
                                 #:norm #t #:args args))
                          exit-val)))
         (do-it! (apply do-it!-proc program args)))
    (lambda (command . args)
      (case (cond ((keyword? command) command)
                  ((symbol? command) (symbol->keyword command))
                  (else #f))
        ((#:redefine) (set! do-it! (apply do-it!-proc (car args) (cdr args))))
        ((#:execute) (outbuf 'erase-buffer) (errbuf 'erase-buffer) (do-it!))
        ((#:execute/no-init) (do-it!))
        ((#:outbuf) (outbuf outbuf))
        ((#:outbuf-string) (outbuf 'buffer-string))
        ((#:outbuf-lines) (outbuf 'buffer-lines))
        ((#:errbuf) (errbuf errbuf))
        ((#:errbuf-string) (errbuf 'buffer-string))
        ((#:errbuf-lines) (errbuf 'buffer-lines))
        ((#:exit-val) (if not-yet
                          (error "program not executed yet")
                          exit-val))
        (else (error "bad command"))))))

;;; internal ((maybe) todo: move this into (ice-9 rdelim))

(define (read-lines --open --close handle-delim)
  (let* ((policy (if (null? handle-delim)
                     'trim
                     (let ((p (car handle-delim)))
                       (case p
                         ((trim concat peek split) p)
                         (else 'trim)))))
         (split? (eq? 'split policy))
         (eof? (if split?
                   (lambda (pair) (eof-object? (cdr pair)))
                   eof-object?))
         (p (--open))
         (lines (accumulator)))
    (define (next)
      (read-line p policy))
    (let loop ((line (next)))
      (cond ((eof? line)
             (and split? (lines line))
             (--close p))
            (else
             (lines line)
             (loop (next)))))
    (lines)))

;; Run shell command @var{cmd} and return its output as a list of strings.
;;
(define (shell-command->list cmd . handle-delim)
  (read-lines (lambda () (open-input-pipe cmd))
              close-pipe
              handle-delim))

;; Run shell command @var{cmd} and return its output as a string.
;;
(define (shell-command->string cmd)
  (apply string-append (shell-command->list cmd 'concat)))

;; Like @code{shell-command->string}, with the command formed
;; by applying @code{simple-format} to @var{s} and @var{args}.
;;
(define (fshell-command->string s . args)
  (shell-command->string (apply fs s args)))

;; Return a list of strings, representing the lines read from @var{port}.
;;
(define (port-lines port . handle-delim)
  (read-lines (lambda () port) identity handle-delim))

;; Return a list of strings, representing the lines found in @var{filename}.
;;
(define (file-lines filename . handle-delim)
  (read-lines (lambda () (open-input-file filename))
              close-port
              handle-delim))

;;; subprocess.scm ends here