454 lines
16 KiB
Scheme
454 lines
16 KiB
Scheme
;;; Gash -- Guile As SHell
|
||
;;; Copyright © 2018, 2019, 2020 Timothy Sample <samplet@ngyro.com>
|
||
;;;
|
||
;;; This file is part of Gash.
|
||
;;;
|
||
;;; Gash is free software: you can redistribute it and/or modify
|
||
;;; it under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation, either version 3 of the License, or
|
||
;;; (at your option) any later version.
|
||
;;;
|
||
;;; Gash is distributed in the hope that it will be useful,
|
||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (gash shell)
|
||
#:use-module (gash built-ins)
|
||
#:use-module (gash compat)
|
||
#:use-module (gash compat textual-ports)
|
||
#:use-module (gash environment)
|
||
#:use-module (gash pattern)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-26)
|
||
#:export (sh:and
|
||
sh:async
|
||
sh:case
|
||
sh:cond
|
||
sh:exec-let
|
||
sh:exec
|
||
sh:for
|
||
sh:not
|
||
sh:or
|
||
sh:pipeline
|
||
sh:set-redirects
|
||
sh:subshell
|
||
sh:substitute-command
|
||
sh:while
|
||
sh:with-redirects
|
||
sh:until))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; This module provides functions for executing Shell language
|
||
;;; constructs.
|
||
;;;
|
||
;;; Code:
|
||
|
||
(define ignore-errexit? (make-parameter #f))
|
||
|
||
(define (without-errexit thunk)
|
||
(parameterize ((ignore-errexit? #t)) (thunk)))
|
||
|
||
(define (errexit)
|
||
(unless (or (zero? (get-status)) (ignore-errexit?))
|
||
(when (getopt 'errexit)
|
||
(sh:exit))))
|
||
|
||
(define (install-current-ports!)
|
||
"Install all current ports into their usual file descriptors. For
|
||
example, if @code{current-input-port} is a @code{file-port?}, make the
|
||
process file descriptor 0 refer to the file open for
|
||
@code{current-input-port}. If any current port is a @code{port?} but
|
||
not a @code{file-port?}, its corresponding file descriptor will refer
|
||
to @file{/dev/null}."
|
||
;; XXX: Input/output ports? Closing other FDs?
|
||
(for-each (lambda (i)
|
||
(match ((fd->current-port i))
|
||
((? file-port? port)
|
||
(dup port i))
|
||
((? input-port? port)
|
||
(dup (open-file "/dev/null" "r") i))
|
||
((? output-port? port)
|
||
(dup (open-file "/dev/null" "w") i))
|
||
(_ #t)))
|
||
(iota *fd-count*)))
|
||
|
||
(define (exec-utility bindings path name args)
|
||
"Execute @var{path} as a subprocess with 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 (get-environ bindings)))
|
||
;; We need to flush all ports here to ensure the proper sequence
|
||
;; of output. Without flushing, output that we have written could
|
||
;; stay in a buffer while the utility (which does not know about
|
||
;; the buffer) produces its output.
|
||
(flush-all-ports)
|
||
(match (primitive-fork)
|
||
(0 (install-current-ports!)
|
||
(apply execle path utility-env name args))
|
||
(pid (match-let (((pid . status) (waitpid pid)))
|
||
(set-status! (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 name)
|
||
"Search for the path of the utility @var{name} using the current
|
||
search path as specified by the environment variable @code{$PATH}. If
|
||
it cannot be found, return @code{#f}."
|
||
(let loop ((prefixes (split-search-path (getvar "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 bindings name . args)
|
||
"Find and execute @var{name} with arguments @var{args} and extra
|
||
environment variable bindings @var{bindings}."
|
||
(when (getopt 'xtrace)
|
||
(format (current-error-port) "+~a\n"
|
||
(string-join (cons name
|
||
(map (lambda (x)
|
||
(if (string-null? x) "''"
|
||
x)) args)))))
|
||
(if (slashless? name)
|
||
(or (and=> (search-special-built-ins name)
|
||
(lambda (proc)
|
||
(for-each (match-lambda
|
||
((name . value)
|
||
(setvar! name value)))
|
||
bindings)
|
||
(set-status! (apply proc args))))
|
||
(and=> (getfun name)
|
||
(lambda (proc)
|
||
(save-variables-excursion (map car bindings)
|
||
(lambda ()
|
||
(for-each (match-lambda
|
||
((name . value)
|
||
(setvar! name value)))
|
||
bindings)
|
||
(with-arguments (cons (car (program-arguments)) args)
|
||
(lambda ()
|
||
(call-with-return
|
||
(lambda ()
|
||
(apply proc args)))))))))
|
||
(and=> (search-built-ins name)
|
||
(lambda (proc)
|
||
(save-variables-excursion (map car bindings)
|
||
(lambda ()
|
||
(for-each (match-lambda
|
||
((name . value)
|
||
(setvar! name value)))
|
||
bindings)
|
||
(let ((exit-val (apply proc args)))
|
||
(set-status! exit-val))))))
|
||
(and=> (find-utility name)
|
||
(lambda (path)
|
||
(exec-utility bindings path name args)))
|
||
(begin (format (current-error-port)
|
||
"~a: ~a: Command not found.~%"
|
||
(car (program-arguments)) name)
|
||
(set-status! 127)))
|
||
(exec-utility bindings name name args))
|
||
(errexit))
|
||
|
||
(define (sh:exec name . args)
|
||
"Find and execute @var{name} with arguments @var{args}."
|
||
(apply sh:exec-let '() name args))
|
||
|
||
|
||
;;; Redirects.
|
||
|
||
(define (process-redir redir)
|
||
"Convert @var{redir} into a list consisting of the current-port
|
||
parameter to be updated, the port that should be its new value (or
|
||
@code{#f} if it should be considered closed), and a boolean indicating
|
||
if it is our responsibility to close the port."
|
||
|
||
(define* (make-processed-redir fd target #:optional (open-flags 0))
|
||
(let ((port (match target
|
||
((? port?) target)
|
||
((? string?) (open target open-flags))
|
||
;; TODO: Verify open-flags.
|
||
((? integer?) ((fd->current-port target)))
|
||
(#f #f))))
|
||
`(,(fd->current-port fd) ,port ,(string? target))))
|
||
|
||
(match redir
|
||
(('< (? integer? fd) (? string? filename))
|
||
(make-processed-redir fd filename O_RDONLY))
|
||
(('> (? integer? fd) (? string? filename))
|
||
(let* ((clobber-flags (logior O_WRONLY O_CREAT O_TRUNC))
|
||
(flags (if (getopt 'noclobber)
|
||
(logior clobber-flags O_EXCL)
|
||
clobber-flags)))
|
||
(make-processed-redir fd filename flags)))
|
||
(('>! (? integer? fd) (? string? filename))
|
||
(make-processed-redir fd filename (logior O_WRONLY O_CREAT O_TRUNC)))
|
||
(('>> fd filename)
|
||
(make-processed-redir fd filename (logior O_WRONLY O_CREAT O_APPEND)))
|
||
(('<> fd filename)
|
||
(make-processed-redir fd filename (logior O_RDWR O_CREAT)))
|
||
(('<& (? integer? fd1) (? integer? fd2))
|
||
(make-processed-redir fd1 fd2))
|
||
(('<& (? integer? fd) '-)
|
||
(make-processed-redir fd #f))
|
||
(('>& (? integer? fd1) (? integer? fd2))
|
||
(make-processed-redir fd1 fd2))
|
||
(('>& (? integer? fd) '-)
|
||
(make-processed-redir fd #f))
|
||
(('<< (? integer? fd) text)
|
||
(let ((port (tmpfile)))
|
||
(display text port)
|
||
(seek port 0 SEEK_SET)
|
||
(make-processed-redir fd port)))))
|
||
|
||
(define (sh:set-redirects redirs)
|
||
"Put the redirects @var{redirs} into effect."
|
||
(let loop ((redirs redirs))
|
||
(match redirs
|
||
(() #t)
|
||
((redir . rest)
|
||
(match (false-if-exception (process-redir redir))
|
||
(#f (set-status! 1)
|
||
(errexit))
|
||
((parameter port close?)
|
||
(parameter port)
|
||
(loop rest)))))))
|
||
|
||
(define (sh:with-redirects redirs thunk)
|
||
"Call @var{thunk} with the redirects @var{redirs} in effect."
|
||
;; This may be too clever! We need to parameterize a variable
|
||
;; number of things in a particular order, and this seems to be the
|
||
;; only way.
|
||
((fold-right (lambda (redir thunk)
|
||
(lambda ()
|
||
(match (false-if-exception (process-redir redir))
|
||
(#f (set-status! 1)
|
||
(errexit))
|
||
((parameter port close?)
|
||
(parameterize ((parameter port))
|
||
(thunk))
|
||
(cond
|
||
(close? (close-port port))
|
||
((output-port? port) (force-output port)))))))
|
||
thunk
|
||
redirs)))
|
||
|
||
|
||
;;; Subshells and command substitution.
|
||
|
||
(define* (%subshell thunk)
|
||
"Run @var{thunk} in a new process and return the ID of the new
|
||
process."
|
||
;; We need to flush all ports before forking to avoid copying the
|
||
;; port buffers into the child process, which could lead to
|
||
;; duplicate output.
|
||
(flush-all-ports)
|
||
(match (primitive-fork)
|
||
(0 (dynamic-wind
|
||
(lambda () #t)
|
||
(lambda ()
|
||
(restore-signals)
|
||
(set-atexit! #f)
|
||
;; We need to preserve the status given to 'exit', so we
|
||
;; catch the 'quit' key here.
|
||
(catch 'quit
|
||
thunk
|
||
(lambda (_ status)
|
||
(primitive-exit status)))
|
||
(primitive-exit (get-status)))
|
||
(lambda ()
|
||
(primitive-exit 1))))
|
||
(pid pid)))
|
||
|
||
(define (sh:subshell thunk)
|
||
"Run @var{thunk} in a subshell environment."
|
||
(match-let* ((pid (%subshell thunk))
|
||
((pid . status) (waitpid pid)))
|
||
(set-status! (status:exit-val status))
|
||
(errexit)))
|
||
|
||
(define (sh:substitute-command 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)
|
||
(with-output-to-port source thunk)))
|
||
(pid (%subshell thunk*)))
|
||
(close-port source)
|
||
(match-let ((result (string-trim-right (get-string-all sink) #\newline))
|
||
((pid . status) (waitpid pid)))
|
||
(set-status! (status:exit-val status))
|
||
(errexit)
|
||
result)))
|
||
|
||
|
||
;;; Pipelines.
|
||
|
||
(define (plumb in out close thunk)
|
||
"Run @var{thunk} in a new process with @code{current-input-port} set
|
||
to @var{in} and @code{current-output-port} set to @var{out}. If
|
||
@var{in} or @var{out} is @code{#f}, the corresponding ``current'' port
|
||
is left unchanged. Unless it is @code{#f}, the port @var{close} will
|
||
be closed in the new process."
|
||
(let* ((thunk* (lambda ()
|
||
(when close (close-port close))
|
||
(let ((in (or in (current-input-port)))
|
||
(out (or out (current-output-port))))
|
||
(parameterize ((current-input-port in)
|
||
(current-output-port out))
|
||
(thunk)))))
|
||
(pid (%subshell thunk*)))
|
||
(when in (close-port in))
|
||
(when out (close-port out))
|
||
pid))
|
||
|
||
(define (waitpid/any pids)
|
||
"Wait for any process with an ID in the list @var{pids} to terminate
|
||
and return its status information."
|
||
(let loop ((interval 10))
|
||
(or (any (lambda (pid)
|
||
(match (waitpid pid WNOHANG)
|
||
((0 . _) #f)
|
||
(x x)))
|
||
pids)
|
||
(begin
|
||
(usleep interval)
|
||
(loop (if (< interval 160)
|
||
(* 2 interval)
|
||
interval))))))
|
||
|
||
(define (sh:pipeline . thunks)
|
||
"Run each thunk in @var{thunks} in its own process with the output
|
||
of each thunk sent to the input of the next thunk."
|
||
(define (plumb-thunks)
|
||
(let loop ((thunks thunks) (in #f) (pids '()))
|
||
(match thunks
|
||
(() pids)
|
||
((thunk) (reverse! (cons (plumb in #f #f thunk) pids)))
|
||
((thunk . rest)
|
||
(match-let (((next-in . out) (pipe)))
|
||
(loop rest next-in (cons (plumb in out next-in thunk) pids)))))))
|
||
|
||
(let ((pids (plumb-thunks)))
|
||
(unless (null? pids)
|
||
(let ((last-pid (last pids)))
|
||
;; We have to wait for all the processes to finish so we can
|
||
;; reap them. We do this by polling them with 'waitpid'.
|
||
;; This is something of a naive approach, but it works for now
|
||
;; and will be easier to improve later when we have job
|
||
;; control.
|
||
(let loop ((pids pids))
|
||
(unless (null? pids)
|
||
(match (waitpid/any pids)
|
||
((pid . status)
|
||
(when (= pid last-pid)
|
||
(set-status! (status:exit-val status)))
|
||
(loop (remove (cut = pid <>) pids)))))))
|
||
(errexit))))
|
||
|
||
|
||
;;; Boolean expressions.
|
||
|
||
(define (sh:and thunk1 thunk2)
|
||
"Run @var{thunk1} and if it exits with status zero, run
|
||
@var{thunk2}."
|
||
(without-errexit thunk1)
|
||
(when (= (get-status) 0)
|
||
(thunk2)
|
||
(errexit)))
|
||
|
||
(define (sh:or thunk1 thunk2)
|
||
"Run @var{thunk1} and if it exits with a nonzero status, run
|
||
@var{thunk2}."
|
||
(without-errexit thunk1)
|
||
(unless (= (get-status) 0)
|
||
(thunk2)
|
||
(errexit)))
|
||
|
||
(define (sh:not thunk)
|
||
"Run @var{thunk}, inverting its exit status."
|
||
(without-errexit thunk)
|
||
(let ((inverted-status (if (= (get-status) 0) 1 0)))
|
||
(set-status! inverted-status)))
|
||
|
||
|
||
;;; Loops.
|
||
|
||
(define (sh:for bindings thunk)
|
||
"Run @var{thunk} for each binding in @var{bindings}. The value of
|
||
@var{bindings} have the form @code{(@var{name} (@var{value} ...))}."
|
||
(set-status! 0)
|
||
(match-let (((name (values ...)) bindings))
|
||
(call-with-break
|
||
(lambda ()
|
||
(for-each (lambda (value)
|
||
(setvar! name value)
|
||
(call-with-continue thunk))
|
||
values)))))
|
||
|
||
(define (sh:while test-thunk thunk)
|
||
(call-with-break
|
||
(lambda ()
|
||
(let loop ((last-status 0))
|
||
(without-errexit test-thunk)
|
||
(cond
|
||
((= (get-status) 0)
|
||
(call-with-continue thunk)
|
||
(loop (get-status)))
|
||
(else
|
||
(set-status! last-status)))))))
|
||
|
||
(define (sh:until test-thunk thunk)
|
||
(sh:while (lambda () (sh:not test-thunk)) thunk))
|
||
|
||
|
||
;;; Conditionals.
|
||
|
||
(define (sh:case value . cases)
|
||
(set-status! 0)
|
||
(let loop ((cases cases))
|
||
(match cases
|
||
(() #t)
|
||
(((patterns thunk) . tail)
|
||
(if (any (cut pattern-match? <> value) patterns)
|
||
(thunk)
|
||
(loop tail))))))
|
||
|
||
(define (sh:cond . cases)
|
||
(let loop ((cases cases))
|
||
(match cases
|
||
(() (set-status! 0))
|
||
(((#t thunk))
|
||
(thunk))
|
||
(((test-thunk thunk) . tail)
|
||
(without-errexit test-thunk)
|
||
(if (= (get-status) 0)
|
||
(thunk)
|
||
(loop tail))))))
|
||
|
||
|
||
;;; Asynchronous commands.
|
||
|
||
(define (sh:async thunk)
|
||
"Run @var{thunk} asynchronously."
|
||
(let ((pid (%subshell thunk)))
|
||
(set-last-job! pid)
|
||
(set-status! 0)))
|