andrius
/
gash
mirror of https://git.savannah.gnu.org/git/gash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Remove unused modules. 

* gash/builtins.scm,
gash/io.scm,
gash/job.scm,
gash/pipe.scm,
gash/script.scm,
gash/shell-utils.scm,
gash/util.scm: Delete files.
* Makefile.am: Remove them.
* gash/gash.scm (main, prompt): Remove calls to deleted job control
procedures.
This commit is contained in:
Timothy Sample 2019-05-16 23:26:11 -04:00
parent 589b92e430
commit ff34039b62
9 changed files with 0 additions and 1885 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Makefile.am
View File

@ -78,24 +78,17 @@ MODULES = \
gash/built-ins/unset.scm \
gash/built-ins/utils.scm \
gash/built-ins.scm \
gash/builtins.scm \
gash/config.scm \
gash/environment.scm \
gash/eval.scm \
gash/gash.scm \
gash/io.scm \
gash/job.scm \
gash/lexer.scm \
gash/parser.scm \
gash/pattern.scm \
gash/pipe.scm \
gash/readline.scm \
gash/repl.scm \
gash/script.scm \
gash/shell-utils.scm \
gash/shell.scm \
gash/textual-ports.scm \
gash/util.scm \
gash/word.scm
bin_SCRIPTS = \

391
gash/builtins.scm
View File

@ -1,391 +0,0 @@
;;; 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 builtins)
#: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 receive)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash gash) ; %prefer-builtins?
#:use-module (gash environment)
#:use-module (gash shell-utils)
#:use-module (gash io)
#:use-module (gash job)
#:use-module (gash pipe)
#:use-module (gash script)
#:use-module (gash util)
#:export (
%builtin-commands
PATH-search-path
trace
bg-command
cd-command
echo-command
eval-command
exit-command
fg-command
help-command
jobs-command
pwd-command
set-command
shift-command
))
(define (PATH-search-path program)
(search-path (string-split (getenv "PATH") #\:) program))
(define (cd-command . args)
(match args
(() (cd-command (getenv "HOME")))
((dir)
(let ((old (variable "OLDPWD")))
(assignment "OLDPWD" (getcwd))
(catch #t
(lambda _
(if (string=? dir "-") (chdir old)
(chdir dir))
0)
(lambda (key command fmt args exit)
(apply format (current-error-port) "cd: ~a: ~a\n" (cons dir args))
1))))
((args ...)
(format (current-error-port) "cd: too many arguments: ~a\n" (string-join args)))))
(define (echo-command . args)
(lambda _
(match args
(() (newline))
(("-n" args ...) (display (string-join args)))
(_ (display (string-join args)) (newline)))))
(define (bg-command . args)
(match args
(() (bg 1))
((job x ...) (bg (string->number (car job))))))
(define (fg-command . args)
(match args
(() (fg 1))
((job x ...) (fg (string->number (car job))))))
(define (jobs-command)
(format (current-error-port) "jobs: ~s\n" job-table)
(for-each (lambda (job) (display-job job)) (reverse job-table)))
(define (pwd-command . _)
(lambda _ (stdout (getcwd))))
(define (set-command . args) ;; TODO export; env vs set
(define (display-var o)
(format #t "~a=~a\n" (car o) (cdr o)))
(match args
(() (lambda _ (for-each display-var %global-variables)))
(("-e") (set-shell-opt! "errexit" #t))
(("+e") (set-shell-opt! "errexit" #f))
(("-u") (set-shell-opt! "nounset" #t))
(("+u") (set-shell-opt! "nounset" #f))
(("-x") (set-shell-opt! "xtrace" #t))
(("+x") (set-shell-opt! "xtrace" #f))
(("-o" option) (format (current-error-port) "warning: set: not supported: ~a\n" args))
(("+o" option) (format (current-error-port) "warning: set: not supported: ~a\n" args))
(((and (? string?) arg)) (let* ((lst (string->string-list arg))
(set (car lst)))
(when (not (member set '("-" "+")))
(error (format #f "set: no such option:~s\n" args)))
(apply set-command (map (cut string-append set <>) (cdr lst)))))
((h ...) (last (map set-command args)))))
(define (shift-command . args)
(lambda _
(match args
(() (when (pair? (cdr (%command-line)))
(%command-line (cons (car (%command-line)) (cddr (%command-line)))))))))
(define (eval-command . args)
(lambda _
(match args
(() #t)
((args ...)
(let ((ast (parse-string (string-join args))))
;;(ignore-error (run ast))
(run ast)
(assignment "?" "0")
#t)))))
(define (exit-command . args)
(match args
(() (exit 0))
((status)
(exit (string->number status)))
((args ...)
(format (current-error-port) "exit: too many arguments: ~a\n" (string-join args)))))
(define (help-command . _)
(lambda _
(display "\
Hello, this is GASH, Guile As SHell.
GASH is work in progress; many language constructs work, globbing
mostly works, pipes work, some redirections work.
")
(display "\nIt has these builtin commands:\n")
(display-tabulated (map car %builtin-commands))))
(define command-command
(case-lambda
(() #t)
(args
(lambda _
(let* ((option-spec
'((describe (single-char #\V))
(help)
(show (single-char #\v))
(version)))
(options (getopt-long (cons "command" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (help? (display "Usage: command [OPTION]... [COMMAND [ARG]...]
Options:
--help display this help and exit
--version display version information and exit
-v display a description of COMMAND similar to the `type' builtin
-V display a more verbose description of COMMAND
"))
(version? (format #t "command (GASH) ~a\n" %version))
((null? files) #t)
((option-ref options 'describe #f)
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(cond (builtin (format #t "~a is a shell builtin\n" command)
0)
(else (let ((program (PATH-search-path command)))
(if (string? program) (begin (format #t "~a hashed (~a)\n" command program) 0)
1))))))
((option-ref options 'show #f)
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(if builtin (begin (stdout command) 0)
(let ((program (PATH-search-path command)))
(if (string? program) (begin (stdout program) 0)
1)))))
(else (let* ((command (car files))
(builtin (builtin command #:prefer-builtin? %prefer-builtins?)))
;; FIXME:
`(command ,@args)))))))))
(define type-command
(case-lambda
(() #t)
(args
(lambda _
(let* ((option-spec
'((help)
(canonical-file-name (single-char #\p))
(version)))
(options (getopt-long (cons "type" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (help? (display "Usage: type [OPTION]... [COMMAND]
Options:
--help display this help and exit
-p display canonical file name of COMMAND
--version display version information and exit
"))
(version? (format #t "type (GASH) ~a\n" %version))
((null? files) #t)
((option-ref options 'canonical-file-name #f)
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(if builtin 0
(let ((program (PATH-search-path command)))
(and (string? program)
(stdout program)
0)))))
(else
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(cond (builtin (format #t "~a is a shell builtin\n" command)
0)
(else (let ((program (PATH-search-path command)))
(if (string? program) (begin (format #t "~a hashed (~a)\n" command program) 0)
1))))))))))))
(define test-command
(case-lambda
(() #f)
(args
(lambda _
(let* ((option-spec
'((is-directory (single-char #\d))
(exists (single-char #\e))
(has-size (single-char #\s))
(help)
(is-directory (single-char #\d))
(is-file (single-char #\f))
(is-symbolic-link (single-char #\L))
(is-symbolic-link (single-char #\h))
(is-readable (single-char #\r))
(is-writable (single-char #\w))
(is-exeutable (single-char #\x))
(string-not-null (single-char #\n))
(string-null (single-char #\z))
(version)))
(options (getopt-long (cons "test" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(file (and (pair? files) (car files)))
(no-options? (and file
(= (length options) 1))))
(cond (help? (display "Usage: test [EXPRESSION]
Expression:
STRING equivalent to -n STRING
STRING1 = STRING2
STRING1 == STRING2
the strings are equal
STRING1 != STRING2
the strings are not equal
Options:
-d FILE FILE exists and is a directory
-e FILE FILE exists
-f FILE FILE exists and is a regular file
-h FILE FILE exists and is a symbolic link (same as -L)
-L FILE FILE exists and is a symbolic link (same as -h)
-n STRING the length of STRING is nonzero
-r FILE FILE exists and read permission is granted
-s FILE FILE exists and has a size greater than zero
-w FILE FILE exists and write permission is granted
-x FILE FILE exists and execute (or search) permission is granted
-z STRING the length of STRING is zero
--help display this help and exit
--version display version information and exit
"))
(version? (format #t "test (GASH) ~a\n" %version))
((null? files) #f)
((or (option-ref options 'string-not-null #f)
(and no-options?
(= (length files) 1)))
(not (string-null? file)))
((option-ref options 'string-null #f)
(string-null? file))
((and (= (length files) 3)
(member (cadr files) '("=" "==")))
(match files
((or (left "=" right)
(left "==" right))
(equal? left right))
((left "!=" right)
(not (equal? left right)))
(expression
(pipeline (command expression)))))
((not (= (length files) 1))
(format (current-error-port) "test: too many files: ~s\n" files)
(format (current-error-port) "test: command: ~s\n" args)
1)
((option-ref options 'is-file #f)
(regular-file? file))
((option-ref options 'is-directory #f)
(directory-exists? file))
((option-ref options 'exists #f)
(file-exists? file))
((option-ref options 'is-symbolic-link #f)
(symbolic-link? file))
((option-ref options 'is-readable #f)
(access? file R_OK))
((option-ref options 'has-size #f)
(and (file-exists? file)
(not (zero? (stat:size (stat file))))))
((option-ref options 'is-writable #f)
(access? file W_OK))
((option-ref options 'is-exeutable #f)
(access? file X_OK))
(else
(error "gash: test: not supported" args))))))))
(define bracket-command
(case-lambda
(() #f)
(args
(cond ((and (pair? args) (equal? (car args) "--help"))
(test-command "--help"))
((and (pair? args) (equal? (car args) "--version"))
(test-command "--version"))
(else
(if (not (equal? (last args) "]")) (begin
(format (current-error-port) "gash: [: missing `]'\n")
#f)
(apply test-command (drop-right args 1))))))))
(define (term->string o)
(match o
((? string?) o)
(('variable name) (variable name))
(('variable-or name default) (variable-or name default))
(('variable-and name default) (variable-and name default))
(_ (format #f "~s" o))))
(define (trace commands)
`(xtrace
,(lambda _
(when (shell-opt? "xtrace")
(for-each
(lambda (o)
(match o
(('command (and command (or (? string?) ('variable _))) ...)
(format (current-error-port) "+ ~a\n" (string-join (map term->string command))))
(('command ('assignment name value))
(format (current-error-port) "+ ~a=~a\n" name (term->string value)))
(_ (format (current-error-port) "+ ~s <FIXME>\n" o))))
(reverse commands))))))
(define %builtin-commands
`(
("bg" . ,bg-command)
("cd" . ,cd-command)
("echo" . ,echo-command)
("eval" . ,eval-command)
("exit" . ,exit-command)
("fg" . ,fg-command)
("help" . ,help-command)
("jobs" . ,jobs-command)
("pwd" . ,pwd-command)
("set" . ,set-command)
("shift" . ,shift-command)
("test" . ,test-command)
("type" . ,type-command)
("[" . ,bracket-command)
))

8
gash/gash.scm
View File

@ -33,13 +33,7 @@
#:use-module (ice-9 regex)
#:use-module (gash config)
#:use-module (gash builtins)
#:use-module (gash environment)
#:use-module (gash job)
#:use-module (gash pipe)
#:use-module (gash io)
#:use-module (gash script)
#:use-module (gash util)
#:use-module (gash environment)
#:use-module (gash eval)
@ -89,7 +83,6 @@ copyleft.
(define (main args)
(let ((thunk
(lambda ()
(job-control-init)
(let* ((option-spec '((command (single-char #\c) (value #t))
(debug (single-char #\d))
(errexit (single-char #\e))
@ -164,7 +157,6 @@ copyleft.
(cwd (if (string-prefix? home cwd)
(string-replace cwd "~" 0 (string-length home))
cwd)))
(report-jobs)
(string-append
l e "[01;32m" r user "@" host l e "[00m" r ":"
l e "[01;34m" r cwd l e "[00m" r (if (zero? (getuid)) "# " "$ "))))))

43
gash/io.scm
View File

@ -1,43 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
;;; 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 io)
#:use-module (srfi srfi-1)
#:export (pke stdout stderr))
(define (output port o)
(map (lambda (o) (display o port)) o)
(newline port)
(force-output port))
(define (stdout . o)
(output (current-output-port) o)
(last o))
(define (stderr . o)
(output (current-error-port) o)
(last o))
(define (pke . stuff)
(newline (current-error-port))
(display ";;; " (current-error-port))
(write stuff (current-error-port))
(newline (current-error-port))
(car (last-pair stuff)))

194
gash/job.scm
View File

@ -1,194 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
;;; 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 job)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (gash io)
#:use-module (gash util)
#:export (
bg
fg
display-job
job-table
job?
job-add-process
job-control-init
job-debug-id
job-setup-process
job-status
new-job
report-jobs
wait
))
(define-record-type <process>
(make-process pid command status)
process?
(pid process-pid)
(command process-command)
(status process-status set-process-status!))
(define-record-type <job>
(make-job id pgid processes debug-id)
job?
(id job-id)
(pgid job-pgid set-job-pgid!)
(processes job-processes set-job-processes!)
(debug-id job-debug-id))
(define debug-id
(let ((id -1))
(lambda ()
(set! id (1+ id))
(number->string id))))
(define (new-job)
(let ((job (make-job (+ 1 (length job-table)) #f '() (debug-id))))
(set! job-table (cons job job-table))
job))
(define job-table '()) ;; list of <job>
(define (job-index index)
(let ((index (- (length job-table) index)))
(if (<= 0 index)
(list-ref job-table index)
#f)))
(define (status->state status)
(cond ((not status) 'Running)
((status:exit-val status) 'Done)
((status:term-sig status) 'Terminated)
((status:stop-sig status) 'Stopped)))
(define (job-command job)
(string-join (map (compose string-join process-command) (reverse (job-processes job))) " | "))
(define (display-job job)
(stdout "[" (job-id job) "] " (map status->state (job-status job)) "\t\t"
(job-command job)))
(define (job-status job)
(map process-status (job-processes job)))
(define (job-update job pid status)
(unless (= 0 pid)
(let ((proc (find (compose (cut eqv? pid <>) process-pid) (job-processes job))))
(when proc
(set-process-status! proc status)))))
(define (job-running? job)
(find (compose not process-status) (job-processes job)))
(define (job-stopped? job)
(find status:stop-sig (filter-map process-status (job-processes job))))
(define (job-completed? job)
(let ((state (map (compose status->state process-status) (job-processes job))))
(every (cut member <> '(Done Terminated)) state)))
(define (add-to-process-group job pid)
(let* ((interactive? (isatty? (current-error-port)))
(pgid (if interactive?
(or (job-pgid job) pid)
(getpgrp))))
(set-job-pgid! job pgid)
(when interactive? (setpgid pid pgid))
pgid))
(define (job-add-process fg? job pid command)
(let ((pgid (add-to-process-group job pid)))
(set-job-pgid! job pgid)
(stderr "job-add-process fg?=~a\n" fg?)
(when (and (isatty? (current-error-port))
fg?)
(tcsetpgrp (current-error-port) pgid))
(set-job-processes! job (cons (make-process pid command #f) (job-processes job)))))
(define (job-setup-process fg? job)
(when (isatty? (current-error-port))
(when (and (isatty? (current-error-port))
fg?)
(tcsetpgrp (current-error-port) (add-to-process-group job (getpid))))
(map (cut sigaction <> SIG_DFL)
(list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD))))
(define (job-control-init)
(when (isatty? (current-error-port))
(let ((pgid (getpgrp)))
(while (and #f ;; FIXME: make check backgrouds our tests
(isatty? (current-error-port))
(not (eqv? (tcgetpgrp (current-error-port)) pgid)))
(kill (- pgid) SIGTTIN))) ;; oops we are not in the foreground
(map (cut sigaction <> SIG_IGN) (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU))
(sigaction SIGCHLD SIG_DFL)
(let ((pid (getpid)))
(setpgid pid pid) ;; create new process group for ourself
(tcsetpgrp (current-error-port) pid))))
(define (reap-jobs)
(set! job-table (filter (disjoin job-running? job-stopped?) job-table)))
(define (report-jobs)
(when (not (null? job-table))
(let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG)))
(pid (car pid-status))
(status (cdr pid-status)))
(unless (= 0 pid)
(map (cut job-update <> pid status) job-table)
(map display-job (filter job-completed? job-table))
(reap-jobs)))))
(define (wait job)
(when (job-running? job)
(let loop ()
(let* ((pid-status (waitpid (- (job-pgid job)) WUNTRACED))
(pid (car pid-status))
(status (cdr pid-status)))
(job-update job pid status)
(if (job-running? job) (loop)))))
(unless (job-completed? job)
(newline) (display-job job))
(reap-jobs)
(or (find (negate zero?) (job-status job))
0))
(define (fg index)
(let ((job (job-index index)))
(cond (job
(let ((pgid (job-pgid job)))
(tcsetpgrp (current-error-port) pgid)
(kill (- (job-pgid job)) SIGCONT))
(stdout (job-command job))
(wait job))
(#t
(stderr "fg: no such job " index)))))
(define (bg index)
(let ((job (job-index index)))
(cond (job
(map (cut set-process-status! <> #f) (job-processes job))
(kill (- (job-pgid job)) SIGCONT))
(#t
(stderr "fg: no such job " index)))))

210
gash/pipe.scm
View File

@ -1,210 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
;;; 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 pipe)
#:use-module (ice-9 curried-definitions)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (gash gash)
#:use-module (gash job)
#:use-module (gash io)
#:export (handle-error pipeline+ pipeline->string substitute))
(define (handle-error job error)
(let ((status (wait job)))
(when (not (zero? status))
(format (current-error-port) "ERROR: exit: ~a: ~s" status error)
(exit status))
status))
(define (pipe*)
(let ((p (pipe)))
(values (car p) (cdr p))))
;; lhs rhs
;; [source] w[1] -> r[0] [filter] w[1] -> r[0] [sink]
;; w[2] -> r[3] [sink]
(define (exec* command) ;; list of strings
(catch #t (lambda () (apply execlp (cons (car command) command)))
(lambda (key . args) (format (current-error-port) "~a\n" (caaddr args))
(exit #f))))
(define ((tee-n file-names) inputs outputs)
(let* ((files (map open-output-file file-names))
(tees (zip files inputs outputs)))
(let loop ((tees tees))
(loop (filter-map (lambda (tee)
(let ((file (first tee))
(input (second tee))
(output (third tee)))
(when (char-ready? input)
(let ((char (read-char input)))
(if (not (eof-object? char))
(begin (display char file)
(display char output)
(list file input output))
#f)))))
tees)))
(map close outputs)))
(define* (spawn fg? job command #:optional (input '()))
(let* ((ofd '(1 2)) ;; output file descriptors 1 & 2
(ifd (cond
((null? input) '())
(#t '(0)))) ;;support no input or 1 input, TODO multiple inputs
(pipes (map (lambda (. _) (pipe)) ofd))
(r (map car pipes))
(w (map cdr pipes))
(pid (primitive-fork)))
(cond ((= 0 pid)
(job-setup-process fg? job)
(map close r)
(if (procedure? command)
(begin
(when (pair? input)
(close-port (current-input-port))
(set-current-input-port (car input)))
(when (pair? w)
(close-port (current-output-port))
(set-current-output-port (car w))
(set-current-error-port (cadr w)))
(let ((status (if (thunk? command) (command)
(command input w))))
(exit (cond ((number? status) status)
((boolean? status) (if status 0 1))
(else 0)))))
(begin
(map dup->fdes w ofd)
(map dup->fdes input ifd)
(exec* command))))
(#t
(job-add-process fg? job pid command)
(map close w)
r))))
(define (pipeline+ fg? . commands)
(when (> %debug-level 0)
(format (current-error-port) "pipeline+[~a]: COMMANDS: ~s\n" fg? commands))
(receive (r w)
(pipe*)
(move->fdes w 2)
(let* ((error-port (set-current-error-port w))
(job (new-job))
(debug-id (job-debug-id job))
(commands
(if (< %debug-level 3) commands
(fold-right (lambda (command id lst)
(let ((file (string-append debug-id "." id)))
(cons* command `("tee" ,file) lst)))
'() commands (map number->string (iota (length commands))))))
(foo (when (> %debug-level 1) (with-output-to-file debug-id (cut format #t "COMMANDS: ~s\n" commands))))
(ports (if (> (length commands) 1)
(let loop ((input (spawn fg? job (car commands) '())) ;; spawn-source
(commands (cdr commands)))
(if (null? (cdr commands))
(spawn fg? job (car commands) input) ;; spawn-sink
(loop (spawn fg? job (car commands) input) ;; spawn-filter
(cdr commands))))
(spawn fg? job (car commands) '())))) ;; spawn-sink
(when fg?
(let loop ((input ports)
(output (list (current-output-port) error-port)))
(let ((line (map (cut read-line <> 'concat) input)))
(let* ((input-available? (lambda (o ln) (and (not (eof-object? ln)) o)))
(line (filter-map input-available? line line))
(output (filter-map input-available? output line))
(input (filter-map input-available? input line)))
(when (pair? input)
(map display line output)
(map (cut force-output <>) output)
(loop input output)))))
(wait job))
(move->fdes error-port 2)
(set-current-error-port error-port)
(close w)
(values job (append ports (list r))))))
(define (pipeline->string . commands)
(receive (job ports)
(apply pipeline+ #f commands)
(let ((output (read-string (car ports))))
(wait job)
output)))
;;(pipeline+ #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") (lambda () (display (read-string))))
;;(pipeline+ #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") '("cat"))
;;(pipeline+ #f (lambda () (display 'foo)) '("grep" "o") '("tr" "o" "e"))
;; (pipeline+ #f
;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar"))
;; '("tr" "u" "a")
;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string))))
;; '("cat")
;; (lambda () (display (read-string))))
;; (receive (job ports)
;; (pipeline+ #f
;; (lambda ()
;; (display "foo")
;; (display "bar" (current-error-port)))
;; '("tr" "o" "e"))
;; (map (compose display read-string) ports))
;; _
;; \
;; -
;; _/
;; (display (pipeline->string
;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar"))
;; '("tr" "u" "a")
;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string))))
;; '("cat")
;; (lambda () (display (read-string)) (newline))))
;; _
;; \
;; -
;; _/
;; (display (pipeline->string
;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar"))
;; '("tr" "u" "a")
;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string))))
;; '("cat")
;; (lambda () (display (read-string)) (newline))))
(define (substitute . commands)
(string-trim-right
(string-map (lambda (c)
(if (eq? #\newline c) #\space c))
(apply pipeline->string commands))
#\space))
;; (display (pipeline->string '("ls") '("cat"))) (newline)
;; (display (substitute '("ls") '("cat"))) (newline)

439
gash/script.scm
View File

@ -1,439 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
;;; 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))

541
gash/shell-utils.scm
View File

@ -1,541 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; 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/>.
;;; Commentary:
;;; The initial guix-build-utils.scm was taken from Guix.
;;; Code:
(define-module (gash shell-utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (ice-9 ftw)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (gash util)
#:export (
delete-file-recursively
display-tabulated
display-file
dump-port
executable-path
file-name-predicate
find-files
file-exists?*
<chmodifier>
make-chmodifier
chmodifier-users
chmodifier-operation
chmodifier-permissions
make-numeric-chmodifier
chmodifier->mode
chmodifiers->mode
apply-chmodifiers
parse-chmodifiers
<grep-match>
grep*
grep+
grep-match-file-name
grep-match-string
grep-match-line
grep-match-column
grep-match-end-column
mkdir-p
rmdir-p
multi-opt
directory-exists?
executable-file?
regular-file?
symbolic-link?
substitute*
substitute-port
with-atomic-file-replacement
let-matches
))
;;; Commentary:
;;; This code is taken from (guix build utils)
;;;
;;; Directories.
;;;
(define (directory-exists? dir)
"Return #t if DIR exists and is a directory."
(let ((s (stat dir #f)))
(and s
(eq? 'directory (stat:type s)))))
(define (executable-file? file)
"Return #t if FILE exists and is executable."
(let ((s (stat file #f)))
(and s
(not (zero? (logand (stat:mode s) #o100))))))
(define (regular-file? file)
"Return #t if FILE is a regular file."
(let ((s (stat file #f)))
(and s
(eq? (stat:type s) 'regular))))
(define (symbolic-link? file)
"Return #t if FILE is a symbolic link (aka. \"symlink\".)"
(let ((s (lstat file)))
(and s
(eq? (stat:type s) 'symlink))))
(define (file-name-predicate regexp)
"Return a predicate that returns true when passed a file name whose base
name matches REGEXP."
(let ((file-rx (if (regexp? regexp)
regexp
(make-regexp regexp))))
(lambda (file stat)
(regexp-exec file-rx (basename file)))))
(define* (find-files dir #:optional (pred (const #t))
#:key (stat lstat)
directories?
fail-on-error?)
"Return the lexicographically sorted list of files under DIR for which PRED
returns true. PRED is passed two arguments: the absolute file name, and its
stat buffer; the default predicate always returns true. PRED can also be a
regular expression, in which case it is equivalent to (file-name-predicate
PRED). STAT is used to obtain file information; using 'lstat' means that
symlinks are not followed. If DIRECTORIES? is true, then directories will
also be included. If FAIL-ON-ERROR? is true, raise an exception upon error."
(let ((pred (if (procedure? pred)
pred
(file-name-predicate pred))))
;; Sort the result to get deterministic results.
(sort (file-system-fold (const #t)
(lambda (file stat result) ; leaf
(if (pred file stat)
(cons file result)
result))
(lambda (dir stat result) ; down
(if (and directories?
(pred dir stat))
(cons dir result)
result))
(lambda (dir stat result) ; up
result)
(lambda (file stat result) ; skip
result)
(lambda (file stat errno result)
(format (current-error-port) "find-files: ~a: ~a~%"
file (strerror errno))
(when fail-on-error?
(error "find-files failed"))
result)
'()
dir
stat)
string<?)))
(define* (delete-file-recursively dir
#:key follow-mounts?)
"Delete DIR recursively, like `rm -rf', without following symlinks. Don't
follow mount points either, unless FOLLOW-MOUNTS? is true. Report but ignore
errors."
(let ((dev (stat:dev (lstat dir))))
(file-system-fold (lambda (dir stat result) ; enter?
(or follow-mounts?
(= dev (stat:dev stat))))
(lambda (file stat result) ; leaf
(delete-file file))
(const #t) ; down
(lambda (dir stat result) ; up
(rmdir dir))
(const #t) ; skip
(lambda (file stat errno result)
(format (current-error-port)
"warning: failed to delete ~a: ~a~%"
file (strerror errno)))
#t
dir
;; Don't follow symlinks.
lstat)))
(define* (dump-port in out
#:key (buffer-size 16384)
(progress (lambda (t k) (k))))
"Read as much data as possible from IN and write it to OUT, using chunks of
BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
transferred and the continuation of the transfer as a thunk."
(define buffer
(make-bytevector buffer-size))
(define (loop total bytes)
(or (eof-object? bytes)
(let ((total (+ total bytes)))
(put-bytevector out buffer 0 bytes)
(progress total
(lambda ()
(loop total
(get-bytevector-n! in buffer 0 buffer-size)))))))
;; Make sure PROGRESS is called when we start so that it can measure
;; throughput.
(progress 0
(lambda ()
(loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
(define-immutable-record-type <grep-match>
(make-grep-match file-name string line column end-column)
grep-match?
(file-name grep-match-file-name)
(string grep-match-string)
(line grep-match-line)
(column grep-match-column)
(end-column grep-match-end-column))
(define* (grep* pattern #:key (port (current-input-port)) (file-name "<stdin>"))
;; FIXME: collect later? for scripting usage implicit collect is
;; nice; for pipeline usage not so much
(let loop ((line (read-line port)) (ln 1) (matches '()))
(if (eof-object? line) (reverse matches)
(let* ((m (list-matches pattern line))
(m (and (pair? m) (car m))))
(loop (read-line port) (1+ ln)
(if m (cons (make-grep-match file-name
(match:string m)
ln
(match:start m)
(match:end m)) matches)
matches))))))
(define (grep+ pattern file)
(cond ((and (string? file)
(not (equal? file "-"))) (call-with-input-file file
(lambda (in)
(grep* pattern #:port in #:file-name file))))
(else (grep* pattern))))
(define (mkdir-p dir)
"Create directory DIR and all its ancestors."
(define absolute?
(string-prefix? "/" dir))
(define not-slash
(char-set-complement (char-set #\/)))
(let loop ((components (string-tokenize dir not-slash))
(root (if absolute?
""
".")))
(match components
((head tail ...)
(let ((path (string-append root "/" head)))
(catch 'system-error
(lambda ()
(mkdir path)
(loop tail path))
(lambda args
(if (= EEXIST (system-error-errno args))
(loop tail path)
(apply throw args))))))
(() #t))))
(define (rmdir-p dir)
"Remove directory DIR and all its ancestors."
(rmdir dir)
(let loop ((dir (dirname dir)))
(when (not (equal? dir "."))
(rmdir dir)
(loop (dirname dir)))))
(define (file-exists?* file)
"Like 'file-exists?' but emits a warning if FILE is not accessible."
(catch 'system-error
(lambda ()
(stat file))
(lambda args
(let ((errno (system-error-errno args)))
(format (current-error-port) "~a: ~a~%"
file (strerror errno))
#f))))
(define* (display-tabulated lst
#:key
(terminal-width 80)
(column-gap 2))
"Display the list of string LST in as many columns as needed given
TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns."
(define len (length lst))
(define column-width
;; The width of a column. Assume all the columns have the same width
;; (GNU ls is smarter than that.)
(+ column-gap (reduce max 0 (map string-length lst))))
(define columns
(max 1
(quotient terminal-width column-width)))
(define pad
(if (zero? (modulo len columns))
0
columns))
(define items-per-column
(quotient (+ len pad) columns))
(define items (list->vector lst))
(let loop ((indexes (unfold (cut >= <> columns)
(cut * <> items-per-column)
1+
0)))
(unless (>= (first indexes) items-per-column)
(for-each (lambda (index)
(let ((item (if (< index len)
(vector-ref items index)
"")))
(display (string-pad-right item column-width))))
indexes)
(newline)
(loop (map 1+ indexes)))))
(define* (display-file file-name #:optional st)
(define (display-rwx perm sticky)
(display (if (zero? (logand perm 4)) "-" "r"))
(display (if (zero? (logand perm 2)) "-" "w"))
(display (let ((x (logand perm 1)))
(if (zero? sticky) (if (zero? x) "-" "x")
(if (= sticky 1) (if (zero? x) "T" "t")
(if (zero? x) "S" "s"))))))
(define (display-bcdfsl type)
(display
(case type
((block-special) "b")
((char-special) "c")
((directory) "d")
((fifo) "p")
((regular) "-")
((socket) "s")
((symlink) "l")
(else "?"))))
(let* ((st (or st (lstat file-name)))
(mode (stat:mode st))
(uid (stat:uid st))
(gid (stat:gid st))
(size (stat:size st))
(date (strftime "%c" (localtime (stat:mtime st))))
(sticky (ash mode -9)))
(display-bcdfsl (stat:type st))
(display-rwx (ash mode -6) (logand sticky 4))
(display-rwx (ash (logand mode #o70) -3) (logand sticky 2))
(display-rwx (logand mode #o7) (logand sticky 1))
(display " ")
(let ((ent (catch #t (compose passwd:name (cut getpwuid uid)) (const uid))))
(format #t "~8a" ent))
(display " ")
(let ((ent (catch #t (compose group:name (cut getgrgid gid)) (const gid))))
(format #t "~8a" ent))
(format #t "~8d" size)
(display " ")
(display date)
(display " ")
(display file-name)
(when (eq? (stat:type st) 'symlink)
(display " -> ")
(display (readlink file-name)))))
(define (multi-opt options name)
(let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o)))))
(filter-map opt? (reverse options))))
(define %not-colon (char-set-complement (char-set #\:)))
(define (executable-path)
"Return the search path for programs as a list."
(match (getenv "PATH")
(#f '())
(str (string-tokenize str %not-colon))))
;;;
;;; Text substitution (aka. sed).
;;;
(define (with-atomic-file-replacement file proc)
"Call PROC with two arguments: an input port for FILE, and an output
port for the file that is going to replace FILE. Upon success, FILE is
atomically replaced by what has been written to the output port, and
PROC's result is returned."
(let* ((template (string-append file ".XXXXXX"))
(out (mkstemp! template))
(mode (stat:mode (stat file))))
(with-throw-handler #t
(lambda ()
(call-with-input-file file
(lambda (in)
(let ((result (proc in out)))
(close out)
(chmod template mode)
(rename-file template file)
result))))
(lambda (key . args)
(false-if-exception (delete-file template))))))
(define (substitute* file pattern+procs)
"PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each
line of FILE, and for each PATTERN that it matches, call the corresponding
PROC as (PROC LINE MATCHES); PROC must return the line that will be written as
a substitution of the original line. Be careful about using '$' to match the
end of a line; by itself it won't match the terminating newline of a line."
(let ((rx+proc (map (match-lambda
;; (((? regexp? pattern) . proc)
;; (cons pattern proc))
(((pattern . flags) . proc)
(cons (apply make-regexp pattern flags)
proc)))
pattern+procs)))
(with-atomic-file-replacement file
(lambda (in out)
(let loop ((line (read-line in 'concat)))
(if (eof-object? line)
#t
(let ((line (fold (lambda (r+p line)
(match r+p
((regexp . proc)
(match (list-matches regexp line)
((and m+ (_ _ ...))
(proc line m+))
(_ line)))))
line
rx+proc)))
(display line out)
(loop (read-line in 'concat)))))))))
(define (substitute-port pattern+procs)
(let ((rx+proc (map (match-lambda
;; (((? regexp? pattern) . proc)
;; (cons pattern proc))
(((pattern . flags) . proc)
(cons (apply make-regexp pattern flags)
proc)))
pattern+procs))
(in (current-input-port))
(out (current-output-port)))
(let loop ((line (read-line in 'concat)))
(if (eof-object? line)
#t
(let ((line (fold (lambda (r+p line)
(match r+p
((regexp . proc)
(match (list-matches regexp line)
((and m+ (_ _ ...))
(proc line m+))
(_ line)))))
line
rx+proc)))
(display line out)
(loop (read-line in 'concat)))))))
;;;
;;; Permissions.
;;;
(define-immutable-record-type <chmodifier>
(make-chmodifier users operation permissions)
chmodifier?
(users chmodifier-users)
(operation chmodifier-operation)
(permissions chmodifier-permissions))
(define (parse-chmodifier o)
(let* ((c (string->symbol (substring o 0 1)))
(o (if (memq c '(- + =)) (string-append "a" o) o))
(users (string->symbol (substring o 0 1)))
(program (car (command-line))))
(when (not (memq users '(u g o a)))
(error (format #f "~a: no such user: ~a" program users)))
(let ((operation (string->symbol (substring o 1 2))))
(when (not (memq operation '(- + =)))
(error (format #f "~a: no such operation: ~a" program operation)))
(let* ((perm-string (substring o 2))
(perm (string->number perm-string 8)))
(if perm (make-numeric-chmodifier perm)
(let ((perms (map string->symbol (string->string-list perm-string))))
(make-chmodifier users operation perms)))))))
(define (parse-chmodifiers o)
(or (and=> (string->number o 8) (compose list (cut make-numeric-chmodifier <>)))
(map parse-chmodifier (string-split o #\,))))
(define (make-numeric-chmodifier o)
(make-chmodifier 'o '= (list o)))
(define* (chmodifiers->mode modifiers #:optional (mode 0))
(let loop ((modifiers modifiers) (mode mode))
(if (null? modifiers) mode
(loop (cdr modifiers)
(chmodifier->mode (car modifiers) mode)))))
(define* (chmodifier->mode modifier #:optional (mode 0))
(let* ((executable? (if (zero? (logand mode #o111)) 0 1))
(n (chmodifier-numeric-mode modifier executable?))
(o (chmodifier-operation modifier))
(program (car (command-line))))
(case o
((=) n)
((+) (logior mode n))
((-) (logand mode (logxor n -1)))
(else (error
(format #f
"~a: operation not supported: ~s\n"
program o))))))
(define (apply-chmodifiers file modifiers)
(let ((mode (chmodifiers->mode modifiers (stat:mode (lstat file)))))
((@ (guile) chmod) file mode)))
(define (chmodifier-numeric-mode o executable?)
(let* ((permissions (chmodifier-permissions o))
(users (chmodifier-users o)))
(let loop ((permissions permissions))
(if (null? permissions) 0
(+ (let* ((p (car permissions))
(base (cond ((number? p) p)
((symbol? p)
(case p
((r) 4)
((w) 2)
((x) 1)
((X) executable?))))))
(case users
((a) (+ base (ash base 3) (ash base 6)))
((o) base)
((g) (ash base 3))
((u) (ash base 6))))
(loop (cdr permissions)))))))

52
gash/util.scm
View File

@ -1,52 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
;;; 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 util)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (
conjoin
disjoin
wrap-command
char->string
string->string-list
string-replace-string
))
(define (disjoin . predicates)
(lambda (. arguments)
(any (cut apply <> arguments) predicates)))
(define (conjoin . predicates)
(lambda (. arguments)
(every (cut apply <> arguments) predicates)))
(define (string->string-list string)
(map char->string (string->list string)))
(define (char->string c)
(make-string 1 c))
(define (string-replace-string string from to)
(cond ((string-contains string from)
=>
(lambda (i)
(string-replace string to i (+ i (string-length from)))))
(else string)))