2018-07-17 03:33:03 +01:00
|
|
|
|
(define-module (geesh shell)
|
2018-07-17 16:20:06 +01:00
|
|
|
|
#:use-module (geesh built-ins)
|
2018-07-17 03:33:03 +01:00
|
|
|
|
#:use-module (geesh environment)
|
|
|
|
|
#:use-module (ice-9 match)
|
2018-07-19 04:41:10 +01:00
|
|
|
|
#:use-module (srfi srfi-26)
|
2018-07-17 03:33:03 +01:00
|
|
|
|
#:export (sh:exec-let
|
2018-07-19 04:41:10 +01:00
|
|
|
|
sh:exec
|
|
|
|
|
sh:with-redirects))
|
2018-07-17 03:33:03 +01:00
|
|
|
|
|
|
|
|
|
;;; 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))))))))
|
|
|
|
|
|
2018-07-19 04:37:21 +01:00
|
|
|
|
(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)))))))
|
|
|
|
|
|
2018-07-17 03:33:03 +01:00
|
|
|
|
(define (sh:exec-let env bindings name . args)
|
2018-07-19 04:37:21 +01:00
|
|
|
|
"Find and execute @var{name} with arguments @var{args}, environment
|
2018-07-17 03:33:03 +01:00
|
|
|
|
@var{env}, and extra environment variable bindings @var{bindings}."
|
2018-07-19 04:37:21 +01:00
|
|
|
|
(if (slashless? name)
|
2018-07-17 16:20:06 +01:00
|
|
|
|
(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)
|
2018-07-19 04:37:21 +01:00
|
|
|
|
(lambda (path)
|
|
|
|
|
(exec-utility env bindings path name args)))
|
|
|
|
|
(error "Command not found."))
|
|
|
|
|
(exec-utility env bindings name name args)))
|
2018-07-17 03:33:03 +01:00
|
|
|
|
|
|
|
|
|
(define (sh:exec env name . args)
|
2018-07-19 04:37:21 +01:00
|
|
|
|
"Find and execute @var{name} with arguments @var{args} and
|
|
|
|
|
environment @var{env}."
|
2018-07-17 03:33:03 +01:00
|
|
|
|
(apply sh:exec-let env '() name args))
|
2018-07-19 04:41:10 +01:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; 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))))))
|