gash/geesh/shell.scm

(define-module (geesh shell)
  #:use-module (geesh built-ins)
  #:use-module (geesh environment)
  #:use-module (ice-9 match)
  #:use-module (ice-9 textual-ports)
  #:use-module (srfi srfi-26)
  #:export (sh:exec-let
            sh:exec
            sh:subshell
            sh:substitute-command
            sh:with-redirects))

;;; Commentary:
;;;
;;; This module provides functions for executing Shell language
;;; constructs.
;;;
;;; Code:

(define (exec-utility env bindings path name args)
  "Execute @var{path} as a subprocess with environment @var{env} and
extra environment variables @var{bindings}.  The first argument given
to the new process will be @var{name}, and the rest of the arguments
will be @var{args}."
  (let ((utility-env (environment->environ env bindings)))
    (match (primitive-fork)
      (0 (apply execle path utility-env name args))
      (pid (match-let (((pid . status) (waitpid pid)))
             (set-var! env "?" (number->string (status:exit-val status))))))))

(define (slashless? s)
  "Test if the string @var{s} does not contain any slashes ('/')."
  (not (string-index s #\/)))

(define (split-search-path s)
  "Split the search path string @var{s}."
  (if (string-null? s) '() (string-split s #\:)))

(define (find-utility env name)
  "Search for the path of the utility @var{name} using @var{env}.  If
it cannot be found, return @code{#f}."
  (let loop ((prefixes (split-search-path (var-ref* env "PATH"))))
    (and (pair? prefixes)
         (let* ((prefix (car prefixes))
                (path (if (string-suffix? "/" prefix)
                          (string-append prefix name)
                          (string-append prefix "/" name))))
           (if (access? path X_OK)
               path
               (loop (cdr prefixes)))))))

(define (sh:exec-let env bindings name . args)
  "Find and execute @var{name} with arguments @var{args}, environment
@var{env}, and extra environment variable bindings @var{bindings}."
  (if (slashless? name)
      (or (and=> (search-special-built-ins name)
                 (lambda (proc)
                   (for-each (match-lambda
                               ((name . value)
                                (set-var! env name value)))
                             bindings)
                   (apply proc env args)))
          ;; TODO: Functions.
          (and=> (search-built-ins name)
                 (lambda (proc)
                   ;; TODO: Use 'bindings' here.
                   (apply proc env args)))
          (and=> (find-utility env name)
                 (lambda (path)
                   (exec-utility env bindings path name args)))
          (error "Command not found."))
      (exec-utility env bindings name name args)))

(define (sh:exec env name . args)
  "Find and execute @var{name} with arguments @var{args} and
environment @var{env}."
  (apply sh:exec-let env '() name args))


;;; Redirects.

(define (save-and-install-redirect! env redir)
  "Install the redirect @var{redir} into the current process and
return a pair consisting of the file descriptor that has been changed
and a dup'ed copy of its old value.  If @var{redir} is a here-document
redirect, the return value is a pair where the first element is the
pair previously described and the second element is the temporary
filename used for the here-document contents."

  (define* (save-and-dup2! fd target #:optional (open-flags 0))
    (let ((saved-fd (catch 'system-error
                      (lambda () (dup fd))
                      (lambda data
                        (unless (= EBADF (system-error-errno data))
                          (apply throw data))
                        #f))))
      (match target
        ((? string?) (dup2 (open-fdes target open-flags) fd))
        ;; TODO: Verify open-flags.
        ((? integer?) (dup2 target fd))
        (#f (close-fdes fd)))
      `(,fd . ,saved-fd)))

  (match redir
    (('< (? integer? fd) (? string? filename))
     (save-and-dup2! fd filename O_RDONLY))
    (('> (? integer? fd) (? string? filename))
     ;; TODO: Observe noclobber.
     (save-and-dup2! fd filename (logior O_WRONLY O_CREAT O_TRUNC)))
    (('>! (? integer? fd) (? string? filename))
     (save-and-dup2! fd filename (logior O_WRONLY O_CREAT O_TRUNC)))
    (('>> fd filename)
     (save-and-dup2! fd filename (logior O_WRONLY O_CREAT O_APPEND)))
    (('<> fd filename)
     (save-and-dup2! fd filename (logior O_RDWR O_CREAT)))
    (('<& (? integer? fd1) (? integer? fd2))
     (save-and-dup2! fd1 fd2))
    (('<& (? integer? fd) '-)
     (save-and-dup2! fd #f))
    (('>& (? integer? fd1) (? integer? fd2))
     (save-and-dup2! fd1 fd2))
    (('>& (? integer? fd) '-)
     (save-and-dup2! fd #f))
    (('<< (? integer? fd) text)
     (let ((port (mkstemp! (string-copy "/tmp/geesh-here-doc-XXXXXX"))))
       (display text port)
       (seek port 0 SEEK_SET)
       `(,(save-and-dup2! fd (port->fdes port)) . ,(port-filename port))))))

(define (restore-saved-fdes! fd-pair)
  "Restore a file-descriptor to its previous state as described by
@var{fd-pair}, where @var{fd-pair} is a return value of
@code{save-and-install-redirect!}."
  (match fd-pair
    (((fd . saved-fd) . filename)
     (restore-saved-fdes! `(,fd . ,saved-fd))
     (delete-file filename))
    ((fd . #f)
     (close-fdes fd))
    ((fd . saved-fd)
     (dup2 saved-fd fd))))

(define (sh:with-redirects env redirs thunk)
  "Call @var{thunk} with the redirects @var{redirs} in effect."
  (let ((saved-fds #f))
    (dynamic-wind
      (lambda ()
        (flush-all-ports)
        (set! saved-fds
          (map (cut save-and-install-redirect! env <>) redirs)))
      thunk
      (lambda ()
        (flush-all-ports)
        (for-each restore-saved-fdes! (reverse saved-fds))))))


;;; Subshells and command substitution.

(define* (%subshell thunk)
  "Run @var{thunk} in a new process and return the ID of the new
process."
  (match (primitive-fork)
    (0 (thunk)
       (primitive-exit))
    (pid pid)))

(define (sh:subshell env thunk)
  "Run @var{thunk} in a subshell environment."
  (match-let* ((pid (%subshell thunk))
               ((pid . status) (waitpid pid)))
    (set-var! env "?" (number->string (status:exit-val status)))))

(define (sh:substitute-command env thunk)
  "Run @var{thunk} in a subshell environment and return its output as
a string."
  (match-let* (((sink . source) (pipe))
               (thunk* (lambda ()
                         (close-port sink)
                         (let ((redirs `((< 0 "/dev/null")
                                         (>& 1 ,(fileno source))
                                         (> 2 "/dev/null"))))
                           (sh:with-redirects env redirs thunk))))
               (pid (%subshell thunk*)))
    (close-port source)
    (match-let ((result (string-trim-right (get-string-all sink) #\newline))
                ((pid . status) (waitpid pid)))
      (set-var! env "?" (number->string (status:exit-val status)))
      result)))