439 lines
15 KiB
Scheme
439 lines
15 KiB
Scheme
;;; Gash --- Guile As SHell
|
|
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; 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 script)
|
|
#:use-module (ice-9 ftw)
|
|
#:use-module (ice-9 getopt-long)
|
|
#:use-module (ice-9 local-eval)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 pretty-print)
|
|
#:use-module (ice-9 rdelim)
|
|
#:use-module (ice-9 receive)
|
|
#:use-module (ice-9 regex)
|
|
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-26)
|
|
|
|
#:use-module (gash builtins)
|
|
#:use-module (gash config)
|
|
#:use-module (gash environment)
|
|
#:use-module (gash gash)
|
|
#:use-module (gash io)
|
|
#:use-module (gash job)
|
|
#:use-module (gash pipe)
|
|
#:use-module (gash util)
|
|
|
|
#:export (
|
|
and-terms
|
|
background
|
|
brace-group
|
|
builtin
|
|
command
|
|
delim
|
|
doublequotes
|
|
file-name
|
|
for-clause
|
|
do-group
|
|
expression
|
|
glob
|
|
ignore-error
|
|
literal
|
|
or-terms
|
|
pipeline
|
|
run
|
|
script-status
|
|
sequence
|
|
singlequotes
|
|
source
|
|
splice
|
|
split
|
|
substitution
|
|
word
|
|
xtrace
|
|
))
|
|
|
|
(define (background term)
|
|
(format (current-error-port) "background: ~s\n" term)
|
|
(match (pke 'background-term term)
|
|
(('pipeline command) (pke 'background: `(pipeline+ #f ,command)))
|
|
(_ term)))
|
|
|
|
(define (source file-name)
|
|
(let* ((string (with-input-from-file file-name read-string))
|
|
(ast (parse-string string)))
|
|
(run ast)))
|
|
|
|
(define (command . args)
|
|
(define (flatten o)
|
|
(match o
|
|
((h t ...) (append (flatten h) (append-map flatten t)))
|
|
(_ (list o))))
|
|
(define (exec command)
|
|
(cond ((procedure? command) command)
|
|
((assoc-ref %functions (car command))
|
|
=>
|
|
(lambda (function)
|
|
(parameterize ((%command-line args))
|
|
(last (apply function args)))))
|
|
((every string? command)
|
|
(let* ((program (car command))
|
|
(escape-builtin? (and (string? program) (string-prefix? "\\" program)))
|
|
(program (if escape-builtin? (string-drop program 1) program))
|
|
(command (cons program (cdr command))))
|
|
(or (builtin command #:prefer-builtin? (or %prefer-builtins?
|
|
escape-builtin?))
|
|
(lambda _ (status:exit-val (apply system* command))))))
|
|
(else (lambda () #t))))
|
|
(when (> %debug-level 1)
|
|
(format (current-error-port) "command: ~s\n" args))
|
|
(let ((args (flatten args)))
|
|
(match args
|
|
(((or "." "source") file-name)
|
|
(let* ((string (with-input-from-file file-name read-string))
|
|
(ast (parse-string string)))
|
|
(run ast)
|
|
0))
|
|
(((? string?) ..1) (exec (append-map glob args)))
|
|
(_ (exec (append-map glob args))))))
|
|
|
|
(define (glob? pattern)
|
|
(and (string? pattern) (string-match "\\?|\\*" pattern)))
|
|
|
|
(define* (glob->regex pattern #:key (begin "^") (end "$"))
|
|
(let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post))
|
|
(pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post))
|
|
(pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post)))
|
|
(make-regexp (string-append begin pattern end))))
|
|
|
|
(define (glob pattern)
|
|
(define (glob-match regex path) ;; pattern path -> bool
|
|
(regexp-match? (regexp-exec regex path)))
|
|
(define (glob- pattern file-names)
|
|
(map (lambda (file-name)
|
|
(if (string-prefix? "./" file-name) (string-drop file-name 2) file-name))
|
|
(append-map (lambda (file-name)
|
|
(map (cut string-append (if (string=? "/" file-name) "" file-name) "/" <>)
|
|
(filter (conjoin (negate (cut string-prefix? "." <>))
|
|
(cute glob-match (glob->regex pattern) <>))
|
|
(or (scandir file-name) '()))))
|
|
file-names)))
|
|
(cond
|
|
((not pattern) '(""))
|
|
((glob? pattern) (let ((absolute? (string-prefix? "/" pattern)))
|
|
(let loop ((patterns (filter (negate string-null?) (string-split pattern #\/)))
|
|
(file-names (if absolute? '("/") '("."))))
|
|
(if (null? patterns)
|
|
file-names
|
|
(begin
|
|
(loop (cdr patterns) (glob- (car patterns) file-names)))))))
|
|
(#t (list pattern))))
|
|
|
|
(define (singlequotes . o)
|
|
(string-join o ""))
|
|
|
|
(define (doublequotes . o)
|
|
(string-join (append-map glob o) ""))
|
|
|
|
(define (sequence . args)
|
|
(let ((glob (append-map glob (apply append args))))
|
|
glob))
|
|
|
|
(define (run script)
|
|
;; fixme: work towards simple eval -- must remove begin for now
|
|
(match script
|
|
(('begin script ...)
|
|
(last (map (cut local-eval <> (the-environment)) script)))
|
|
(_ (local-eval script (the-environment)))))
|
|
|
|
(define (script-status)
|
|
((compose string->number variable) "?"))
|
|
|
|
(define (for-clause name sequence body)
|
|
(for-each (lambda (value)
|
|
(assignment name value)
|
|
(body))
|
|
sequence))
|
|
|
|
(define (split o)
|
|
((compose string-tokenize string-trim-right) o))
|
|
|
|
(define (xtrace o)
|
|
(o))
|
|
|
|
(define (literal o)
|
|
o)
|
|
|
|
(define (word . o)
|
|
(define (flatten o)
|
|
(match o
|
|
((h t ...) (append (flatten h) (append-map flatten t)))
|
|
(_ (list o))))
|
|
(match o
|
|
(((? string?) ...) (string-join (flatten o) ""))
|
|
((((? string?) ...)) (flatten (car o)))
|
|
(_ o)))
|
|
|
|
(define-syntax-rule (substitution commands)
|
|
(string-trim-right (with-output-to-string (lambda _ commands))))
|
|
|
|
(define-syntax-rule (ignore-error o)
|
|
(let ((errexit (shell-opt? "errexit")))
|
|
(when errexit
|
|
(set-shell-opt! "errexit" #f))
|
|
(let ((r o))
|
|
(assignment "?" "0")
|
|
(when errexit
|
|
(set-shell-opt! " errexit" #t))
|
|
r)))
|
|
|
|
(define-syntax true?
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ pipeline)
|
|
(with-syntax ((it (datum->syntax x 'it)))
|
|
#'(let ((it (ignore-error pipeline)))
|
|
(status->bool it)))))))
|
|
|
|
(define (status->bool o)
|
|
(match o
|
|
(#t #t)
|
|
((? number?) (zero? o))
|
|
(_ #f)))
|
|
|
|
(define-syntax expression
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ (command word ...))
|
|
#'(list word ...)))))
|
|
|
|
(define-syntax do-group
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ term ...)
|
|
#'(lambda _ term ...)))))
|
|
|
|
(define-syntax and-terms
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ left right)
|
|
(with-syntax ((it (datum->syntax x 'it)))
|
|
#'(let ((it left))
|
|
(if (zero? it) right it)))))))
|
|
|
|
(define-syntax or-terms
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ left right)
|
|
(with-syntax ((it (datum->syntax x 'it)))
|
|
#'(let ((it (ignore-error left)))
|
|
(if (zero? it) it right)))))))
|
|
|
|
(define (pipeline . commands)
|
|
(define (handle job)
|
|
(when (> %debug-level 1)
|
|
(format (current-error-port) "job=~s\n" job))
|
|
(let* ((stati (cond ((job? job) (map status:exit-val (job-status job)))
|
|
((boolean? job) (list (if job 0 1)))
|
|
((number? job) (list job))
|
|
(else (list 0))))
|
|
(foo (when (> %debug-level 1)
|
|
(format (current-error-port) "stati=~s\n" stati)))
|
|
(status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0)
|
|
(car stati)))
|
|
(pipestatus (string-append
|
|
"("
|
|
(string-join
|
|
(map (lambda (s i)
|
|
(format #f "[~a]=\"~a\"" s i))
|
|
stati
|
|
(iota (length stati))))
|
|
")")))
|
|
(assignment "PIPESTATUS" pipestatus)
|
|
(assignment "?" (number->string status))
|
|
(when (and (not (zero? status))
|
|
(shell-opt? "errexit"))
|
|
(when (> %debug-level 0)
|
|
(format (current-error-port) "set -e: exiting\n"))
|
|
(exit status))
|
|
(status->bool status)))
|
|
(let ((commands (filter (lambda (x) (not (eq? x *unspecified*))) commands)))
|
|
(when (> %debug-level 1)
|
|
(format (current-error-port) "pijp: commands=~s\n" commands))
|
|
;; FIXME: after running a builtin, we still end up here with the builtin's result
|
|
;; that should probably not happen, however, cater for it here for now
|
|
(match commands
|
|
(((and (? boolean?) boolean))
|
|
(handle boolean))
|
|
(((and (? number?) number))
|
|
(handle number))
|
|
(((? unspecified?))
|
|
(handle #t))
|
|
(((? unspecified?) t ... #t)
|
|
#t)
|
|
(_ (handle (apply pipeline+ #t commands))))))
|
|
|
|
(define* (builtin ast #:key prefer-builtin?)
|
|
;; FIXME: distinguish between POSIX compliant builtins and
|
|
;; `best-effort'/`fallback'?
|
|
"Possibly modify command to use a builtin."
|
|
(when (> %debug-level 0)
|
|
(format (current-error-port) "builtin ast=~s\n" ast))
|
|
(receive (command args)
|
|
(match ast
|
|
(((and (? string?) command) args ...) (values command args))
|
|
(_ (values #f #f)))
|
|
(let ((program (and command
|
|
(cond ((string-prefix? "/" command)
|
|
(when (not (file-exists? command))
|
|
(format (current-error-port) "gash: ~a: no such file or directory\n" command))
|
|
command)
|
|
(else (PATH-search-path command))))))
|
|
;; FIXME: find some generic strerror/errno way: what about permissions and stuff?
|
|
;; after calling system* we're too late for that?
|
|
(when (> %debug-level 0)
|
|
(format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args))
|
|
(cond ((and program (not prefer-builtin?))
|
|
(when (not program)
|
|
(format (current-error-port) "gash: ~a: command not found\n" command))
|
|
(when (not (access? program X_OK))
|
|
(format (current-error-port) "gash: ~a: permission denied\n" command))
|
|
#f)
|
|
((and command (or (assoc-ref %builtin-commands command)))
|
|
=>
|
|
(lambda (command)
|
|
(if args
|
|
(apply command (map (cut local-eval <> (the-environment)) args))
|
|
(command))))
|
|
(else #f)))))
|
|
|
|
(define (brace-group . o)
|
|
o)
|
|
|
|
(define (file-name o)
|
|
o)
|
|
|
|
(define (regexp-exec-non-greedy regexp string)
|
|
(let ((max (string-length string)))
|
|
(let loop ((size 1))
|
|
(and (<= size max)
|
|
(or (regexp-exec regexp (substring string 0 size))
|
|
(loop (1+ size)))))))
|
|
|
|
(define (regexp-exec-non-greedy-reverse regexp string)
|
|
(let ((max (string-length string)))
|
|
(let loop ((start (1- max)))
|
|
(and (>= start 0)
|
|
(or (regexp-exec regexp (substring string start))
|
|
(loop (1- start)))))))
|
|
|
|
(define (variable-regex name sep pattern)
|
|
(match sep
|
|
("##" (variable-hash-hash name pattern))
|
|
("#" (variable-hash name pattern))
|
|
("%%" (variable-percent-percent name pattern))
|
|
("%" (variable-percent name pattern))
|
|
("/" (variable-replace name pattern))))
|
|
|
|
(define (variable-replace name pattern)
|
|
(let* ((value (variable name))
|
|
(at (string-index pattern #\/))
|
|
(regex (if at (substring pattern 0 at) pattern))
|
|
(subst (if at (substring pattern (1+ at)) "")))
|
|
(regexp-substitute/global #f regex value 'pre subst 'post)))
|
|
|
|
(define (variable-hash name pattern)
|
|
(let ((value (variable name))
|
|
(glob? (glob? pattern)))
|
|
(if glob? (let* ((regexp (glob->regex pattern #:end ""))
|
|
(match (regexp-exec-non-greedy regexp value)))
|
|
(if match (string-drop value (match:end match))
|
|
value))
|
|
(if (string-prefix? pattern value) (string-drop value (string-length pattern))
|
|
value))))
|
|
|
|
(define (variable-hash-hash name pattern)
|
|
(let ((value (variable name))
|
|
(glob? (glob? pattern)))
|
|
(if glob? (let* ((regexp (glob->regex pattern #:end ""))
|
|
(match (regexp-exec regexp value)))
|
|
(if match (string-drop value (match:end match))
|
|
value))
|
|
(if (string-prefix? pattern value) (string-drop value (string-length pattern))
|
|
value))))
|
|
|
|
(define (variable-percent name pattern)
|
|
(let ((value (variable name))
|
|
(glob? (glob? pattern)))
|
|
(if glob? (let* ((regexp (glob->regex pattern #:begin ""))
|
|
(match (regexp-exec-non-greedy-reverse regexp value)))
|
|
(if match (substring value 0 (- (string-length value) (match:end match)))
|
|
value))
|
|
(if (string-suffix? pattern value) (substring value 0 (string-length pattern))
|
|
value))))
|
|
|
|
(define (variable-percent-percent name pattern)
|
|
(let ((value (variable name))
|
|
(glob? (glob? pattern)))
|
|
(if glob? (let* ((regexp (glob->regex pattern #:begin ""))
|
|
(match (regexp-exec regexp value)))
|
|
(if match (substring value 0 (match:start match))
|
|
value))
|
|
(if (string-suffix? pattern value) (substring value 0 (string-length pattern))
|
|
value))))
|
|
|
|
(define (number o)
|
|
o)
|
|
|
|
(define (pat o)
|
|
o)
|
|
|
|
(define (str o)
|
|
o)
|
|
|
|
(define* (variable-slash name pattern #:optional (replace ""))
|
|
(let ((value (variable name))
|
|
(glob? (glob? pattern)))
|
|
(let ((match (if glob? (let ((regexp (glob->regex pattern #:begin "" #:end "")))
|
|
(regexp-exec regexp value))
|
|
(string-match pattern value))))
|
|
(if match (string-append
|
|
(substring value 0 (match:start match))
|
|
replace
|
|
(substring value (match:end match)))
|
|
value))))
|
|
|
|
(define (compound . o)
|
|
(match o
|
|
((h ... t) t)
|
|
(_ o)))
|
|
|
|
(define (delim o . rest)
|
|
(match rest
|
|
(() o)
|
|
(((? string?) ...) (string-append o (string-join rest "")))
|
|
((((? string?) ...)) (string-append o (string-join (car rest) "")))))
|
|
|
|
(define (name o)
|
|
o)
|
|
|
|
(define (regex-sep o)
|
|
o)
|
|
|
|
(define (shift . o)
|
|
(apply (shift-command) o))
|