diff --git a/Makefile.am b/Makefile.am index cfe87b9..e1c9063 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 = \ diff --git a/gash/builtins.scm b/gash/builtins.scm deleted file mode 100644 index 6cc25bf..0000000 --- a/gash/builtins.scm +++ /dev/null @@ -1,391 +0,0 @@ -;;; Gash --- Guile As SHell -;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen -;;; -;;; 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 . - -(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 \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) - )) diff --git a/gash/gash.scm b/gash/gash.scm index cbd3d65..89b4197 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -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)) "# " "$ ")))))) diff --git a/gash/io.scm b/gash/io.scm deleted file mode 100644 index 654152b..0000000 --- a/gash/io.scm +++ /dev/null @@ -1,43 +0,0 @@ -;;; Gash --- Guile As SHell -;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom -;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen -;;; -;;; 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 . - -(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))) diff --git a/gash/job.scm b/gash/job.scm deleted file mode 100644 index dbd9de0..0000000 --- a/gash/job.scm +++ /dev/null @@ -1,194 +0,0 @@ -;;; Gash --- Guile As SHell -;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom -;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen -;;; -;;; 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 . - -(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 - (make-process pid command status) - process? - (pid process-pid) - (command process-command) - (status process-status set-process-status!)) - -(define-record-type - (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 - -(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))))) diff --git a/gash/pipe.scm b/gash/pipe.scm deleted file mode 100644 index ac06a68..0000000 --- a/gash/pipe.scm +++ /dev/null @@ -1,210 +0,0 @@ -;;; Gash --- Guile As SHell -;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom -;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen -;;; -;;; 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 . - -(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) diff --git a/gash/script.scm b/gash/script.scm deleted file mode 100644 index df898f9..0000000 --- a/gash/script.scm +++ /dev/null @@ -1,439 +0,0 @@ -;;; Gash --- Guile As SHell -;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom -;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen -;;; -;;; 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 . - -(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)) diff --git a/gash/shell-utils.scm b/gash/shell-utils.scm deleted file mode 100644 index 4c27624..0000000 --- a/gash/shell-utils.scm +++ /dev/null @@ -1,541 +0,0 @@ -;;; Gash --- Guile As SHell -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès -;;; Copyright © 2013 Andreas Enge -;;; Copyright © 2013 Nikita Karetnikov -;;; Copyright © 2015, 2018 Mark H Weaver -;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen -;;; -;;; 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 . - -;;; 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?* - - - make-chmodifier - chmodifier-users - chmodifier-operation - chmodifier-permissions - make-numeric-chmodifier - chmodifier->mode - chmodifiers->mode - apply-chmodifiers - parse-chmodifiers - - - 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 - (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 "")) - ;; 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 - (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))))))) diff --git a/gash/util.scm b/gash/util.scm deleted file mode 100644 index 908725e..0000000 --- a/gash/util.scm +++ /dev/null @@ -1,52 +0,0 @@ -;;; Gash --- Guile As SHell -;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom -;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen -;;; -;;; 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 . - -(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)))