├── test ├── foo bar │ └── a file └── literal.txt ├── package.lisp ├── hooks.lisp ├── cmd.asd ├── .github └── workflows │ └── ci.yml ├── LICENSE.txt ├── test.lisp ├── README.md └── cmd.lisp /test/foo bar/a file: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | -------------------------------------------------------------------------------- /test/literal.txt: -------------------------------------------------------------------------------- 1 | literal string 2 | -------------------------------------------------------------------------------- /hooks.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cmd/hooks 2 | (:use :cl :alexandria :serapeum) 3 | (:export :*message-hook* *proc-hook*)) 4 | (in-package :cmd/hooks) 5 | 6 | (defvar *message-hook* '()) 7 | 8 | (defvar *proc-hook* '()) 9 | -------------------------------------------------------------------------------- /cmd.asd: -------------------------------------------------------------------------------- 1 | ;;;; cmd.asd 2 | 3 | (defsystem "cmd" 4 | :description "A utility for running external programs" 5 | :author "Paul M. Rodriguez " 6 | :license "MIT" 7 | :version "0.0.1" 8 | :serial t 9 | :class :package-inferred-system 10 | :depends-on ("cmd/cmd") 11 | :in-order-to ((test-op (load-op "cmd/test"))) 12 | :perform (test-op (o c) (symbol-call :cmd/test :run-tests))) 13 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | env: 6 | GITHUB_WORKSPACE: $HOME/common-lisp/cmd 7 | 8 | jobs: 9 | test: 10 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 11 | runs-on: ${{ matrix.os }} 12 | strategy: 13 | matrix: 14 | lisp: [sbcl-bin, ccl-bin/1.12.1] 15 | os: [ubuntu-latest, macOS-13] 16 | 17 | steps: 18 | - uses: actions/checkout@v1 19 | - name: Install Roswell 20 | env: 21 | LISP: ${{ matrix.lisp }} 22 | run: | 23 | curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh 24 | - name: Install ci-utils 25 | run: ros install ci-utils 26 | - name: Run tests 27 | run: | 28 | PATH="~/.roswell/bin:$PATH" 29 | run-fiveam -l cmd/test 'cmd/test::run-tests' 30 | - name: Run compile-bundle-op 31 | run: | 32 | ros run 33 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020 Paul M. Rodriguez 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :cmd/test 2 | (:use :cl :cmd/cmd :fiveam :alexandria :serapeum) 3 | ;; Internal symbols. 4 | (:import-from 5 | :cmd/cmd 6 | :parse-cmd-dsl 7 | :expand-keyword-aliases 8 | :flatten-string-tokens 9 | :kill-process-group 10 | :split-cmd 11 | :vterm-terminal 12 | :wrap-cmd-env) 13 | (:import-from :uiop :os-unix-p :subprocess-error) 14 | (:export :run-tests)) 15 | (in-package :cmd/test) 16 | 17 | (def-suite cmd) 18 | (in-suite cmd) 19 | 20 | (defun run-tests () 21 | (run! 'cmd)) 22 | 23 | (test filename-starts-with-dash 24 | (signals error 25 | (eval '(cmd "ls" #p"-file")))) 26 | 27 | (defmacro unix-test (name &body body) 28 | `(test ,name 29 | (if (os-unix-p) 30 | (progn ,@body) 31 | (skip "Not on Unix")))) 32 | 33 | (unix-test unix-cmd 34 | (let ((*shell* (resolve-executable "bash"))) 35 | (is (equal* "hello" 36 | ($cmd "echo hello") 37 | ($cmd '("echo" "hello")) 38 | ($cmd "echo" #p"hello") 39 | ($cmd '("echo" #p "hello")) 40 | ($sh "echo hello") 41 | ($sh "echo 'hello'") 42 | ($sh "echo \"hello\"")))) 43 | (let ((file (asdf:system-relative-pathname :cmd "test/literal.txt"))) 44 | (is (equal (chomp (read-file-into-string file)) 45 | ($cmd "cat" file))))) 46 | 47 | (unix-test here-string 48 | (is (equal* ($cmd "bash -c" '("read x; echo \"$x\"") :<<< "hello") 49 | ($cmd "bash -c" '("read x; echo \"$x\"; exit 1") :<<< "hello" 50 | :check nil) 51 | (let ((*shell* (resolve-executable "bash"))) 52 | ($sh "read x; echo \"$x\"" :<<< "hello")) 53 | "hello"))) 54 | 55 | (unix-test pipelines 56 | (is (string= "oof" ($cmd "echo 'foo' | rev"))) 57 | (is (string= (fmt "rab~%oof") ($cmd "echo -e 'foo\\nbar' | rev | tac"))) 58 | (let ((string1 59 | ($cmd "cat /usr/share/dict/words" 60 | "|" '("sort") 61 | "|" '("uniq" "-c") 62 | "|" '("sort" "-nrs") 63 | "|" '("head" "-3"))) 64 | (string2 65 | ($cmd "cat /usr/share/dict/words | sort | uniq -c | sort -nrs | head -3"))) 66 | (is (length= 3 67 | (lines string1) 68 | (lines string2))) 69 | (is (equal string1 string2)))) 70 | 71 | (test expand-keyword-aliases 72 | (is 73 | (equal 74 | (expand-keyword-aliases '(:|2>\|| "bar.txt")) 75 | '(:if-error-output-exists :supersede 76 | :error-output "bar.txt")))) 77 | 78 | (test split-cmd 79 | (flet ((split-cmd (x) (flatten-string-tokens (split-cmd x)))) 80 | (is (equal '("x" :> "y") (split-cmd "x > y"))) 81 | (is (equal '("x" :|\|| "y" :|\|| "z") (split-cmd "x | y | z"))))) 82 | 83 | (unix-test pipefail 84 | (signals subprocess-error 85 | (cmd "bash -c 'echo hello; exit 1'" :> nil)) 86 | ;; TODO This doesn't work on CCL or SBCL. The problem is that the 87 | ;; exit code actually gets set to zero. 88 | ;; (signals subprocess-error 89 | ;; (cmd "bash -c 'echo hello; exit 1' | rev")) 90 | ) 91 | 92 | (unix-test tokenize-regression 93 | (is-true (cmd? "echo \"sleep 5000\" | grep -qo -e 'sleep 5000'"))) 94 | 95 | (unix-test kill-pipeline 96 | (let ((proc (cmd& "sleep 5000 | echo 'done'"))) 97 | (kill-process-group proc) 98 | (is (null (cmd? "pidof sleep"))))) 99 | 100 | (unix-test psub 101 | (is-true (cmd? "diff" (psub "echo 'x'") (psub "echo 'x'"))) 102 | (is (equal "1c1" 103 | (first 104 | (lines 105 | ($cmd "diff" 106 | :check nil 107 | (psub "echo -e 'hello\nworld'") 108 | (psub "echo -e 'goodbye\nworld'"))))))) 109 | 110 | (unix-test psub-echo 111 | (is-true (cmd? "diff" (psub-echo "x") (psub-echo "x"))) 112 | (is (equal "2c2" 113 | (first 114 | (lines 115 | ($cmd "diff" 116 | :check nil 117 | (psub-format "hello~%world") 118 | (psub-format "hello~%dolly"))))))) 119 | 120 | (unix-test stringify-regression 121 | (finishes (cmd! :in "/tmp" "ls"))) 122 | 123 | (unix-test output-file-regression 124 | (let ((file (string+ "/tmp/cmd-hello-" (random 10000)))) 125 | ;; Bug only happens when file gets passed through as a string token. 126 | (cmd (fmt "echo -n hello > ~a" file)) 127 | (is (equal "hello" (read-file-into-string file))) 128 | (uiop:delete-file-if-exists file))) 129 | 130 | (test with-working-directory 131 | (let* ((tmp (uiop:temporary-directory)) 132 | (new-dir-name (string+ "cmd-test-dir-" (random 10000) ".foo")) 133 | (new-dir 134 | (ensure-directories-exist 135 | (uiop:ensure-directory-pathname 136 | (path-join tmp new-dir-name))))) 137 | (unwind-protect 138 | (with-working-directory (new-dir) 139 | (is (equal *default-pathname-defaults* 140 | (path-join tmp 141 | (make-pathname 142 | :directory `(:relative ,new-dir-name))))) 143 | (let ((subdir 144 | (ensure-directories-exist 145 | (path-join new-dir 146 | (make-pathname 147 | :directory '(:relative "subdir.foo")))))) 148 | (with-working-directory ("subdir.foo") 149 | (equal *default-pathname-defaults* subdir)))) 150 | (uiop:delete-directory-tree 151 | new-dir :validate (op (string*= ".foo" (namestring _))))))) 152 | 153 | (unix-test dont-parse-keyword-value-as-arg 154 | (with-working-directory ((uiop:temporary-directory)) 155 | (let ((subdir (string+ "temp-" (random 10000) ".foo"))) 156 | (cmd "mkdir" subdir) 157 | (unwind-protect 158 | (with-working-directory (subdir) 159 | (let* ((x (string+ "x-" (random 10000) ".foo")) 160 | (y (string+ "y-" (random 10000) ".foo")) 161 | (string (string+ x " " y))) 162 | (cmd "echo hello" :> string) 163 | (is (uiop:file-exists-p string)) 164 | (is (not (uiop:file-exists-p x))) 165 | (is (not (string*= y (read-file-into-string string)))))) 166 | (uiop:delete-directory-tree 167 | (path-join (uiop:temporary-directory) 168 | (make-pathname 169 | :directory `(:relative ,subdir))) 170 | :validate (op (string*= ".foo" (namestring _)))))))) 171 | 172 | (unix-test do-parse-keywordlike-string-value-as-arg 173 | (with-working-directory ((uiop:temporary-directory)) 174 | (let ((subdir (string+ "temp-" (random 10000) ".foo"))) 175 | (cmd "mkdir" subdir) 176 | (unwind-protect 177 | (with-working-directory (subdir) 178 | (let* ((x (string+ "x-" (random 10000) ".foo")) 179 | (y (string+ "y-" (random 10000) ".foo")) 180 | (string (string+ x " " y))) 181 | (cmd "echo hello" ">" string) 182 | (is (not (uiop:file-exists-p string))) 183 | (is (uiop:file-exists-p x)) 184 | (is (string*= y (read-file-into-string x))))) 185 | (uiop:delete-directory-tree 186 | (path-join (uiop:temporary-directory) 187 | (make-pathname 188 | :directory `(:relative ,subdir))) 189 | :validate (op (string*= ".foo" (namestring _)))))))) 190 | 191 | (test wrap-cmd-env 192 | (is (equal '("hello") 193 | (let ((*cmd-env* '())) 194 | (wrap-cmd-env '("hello"))))) 195 | (is (equal '("env" "GIT_PAGER=cat" "hello") 196 | (let ((*cmd-env* '(("GIT_PAGER" . "cat")))) 197 | (wrap-cmd-env '("hello")))))) 198 | 199 | (unix-test cmd-env-no-escape 200 | (is (equal "foo=bar" 201 | (let* ((var-name (gensym)) 202 | (*cmd-env* `((,var-name . "foo=bar")))) 203 | ($cmd (fmt "sh -c 'echo $~a'" var-name)))))) 204 | 205 | (unix-test cmd-env-valid-name 206 | (signals error 207 | (let* ((*cmd-env* `(("invalid=name" . "foo=bar")))) 208 | ($cmd (fmt "sh -c 'echo ${invalid-name}'"))))) 209 | 210 | (test vterm-cmd-package 211 | (let ((*package* (find-package :keyword))) 212 | (is (some (op (search "(vterm)" _)) 213 | (vterm-terminal '()))))) 214 | 215 | (defun foo (string) 216 | (cmd:$cmd "bash -c 'echo $0; echo busted >&2; exit 1'" string)) 217 | 218 | (defun some-user-function () 219 | (let ((cmd::*null-error-output* (make-string-output-stream))) 220 | (handler-case (foo "hello") 221 | (uiop/run-program:subprocess-error () 222 | (princ (get-output-stream-string cmd::*null-error-output*)) 223 | ;; print or resignal an error using stderr output here 224 | )))) 225 | 226 | (unix-test cmd-null-error-override 227 | (is (string= (fmt "busted~%") 228 | (with-output-to-string (*standard-output*) 229 | (some-user-function))))) 230 | 231 | (unix-test private-stderr-stream-regression 232 | (let ((error 233 | (handler-case 234 | (foo "hello") 235 | (error (e) e)))) 236 | (is (string*= "busted" (princ-to-string error))))) 237 | 238 | (test pathname-with-space 239 | (with-working-directory ((asdf:system-relative-pathname "cmd" "test/")) 240 | (is (uiop:directory-exists-p "foo bar")) 241 | (is (string= "a file" ($cmd "ls" #p"foo bar"))) 242 | (locally (declare (notinline $cmd)) 243 | (is (string= "a file" ($cmd "ls" #p"foo bar")))))) 244 | 245 | (test parse-cmd-dsl 246 | (is (equal 247 | (multiple-value-list 248 | (parse-cmd-dsl '("echo 'hello world' > myfile"))) 249 | '(("echo" "hello world") 250 | (:output "myfile"))))) 251 | 252 | (test visual-command-regression 253 | "Checking for a visual command shouldn't break on a path without a 254 | pathname-name." 255 | (finishes (cmd "env -C / ls" :> nil))) 256 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cmd 2 | 3 | A utility for running external programs, built on 4 | [`uiop:launch-program`][UIOP]. 5 | 6 | Cmd is designed to: 7 | 8 | 1. Be natural to use. 9 | 2. Protect against shell interpolation. 10 | 3. Be usable from multi-threaded programs. 11 | 4. Support Windows. 12 | 13 | ## Argument handling 14 | 15 | Arguments to `cmd` are *never* passed to a shell for interpretation. 16 | 17 | Arguments are usually: 18 | - strings 19 | - keywords 20 | - lists of strings and keywords 21 | 22 | Some other types get special handling. Nested lists are not allowed. 23 | 24 | Arguments are handled as follows: 25 | 26 | 1. A string is tokenized (using [cl-shlex][]) and added to the list of 27 | arguments. 28 | 29 | ``` lisp 30 | (cmd "ls -al") 31 | ≅ (uiop:wait-process (uiop:launch-program '("ls" "-al"))) 32 | 33 | (cmd "echo 'hello world'") 34 | ≅ (uiop:wait-process (uiop:launch-program '("echo" "hello world"))) 35 | ``` 36 | 37 | Redirection operators in the tokenized string (such as `<`, `>`, or 38 | `|`) are translated into keywords (see below). 39 | 40 | ```lisp 41 | (cmd "echo 'hello world' > myfile") 42 | ≡ (cmd '("echo" "hello world" :> "myfile")) 43 | ``` 44 | 45 | 2. A list is added directly to the list of arguments (not tokenized). 46 | (Putting a string in a list is “escaping” it.) 47 | 48 | ``` lisp 49 | (cmd "bash -c 'exit 1'") 50 | ≡ (cmd "bash -c" '("exit 1")) 51 | ``` 52 | 53 | Keywords in the list are treated exactly like keywords as 54 | arguments. 55 | 56 | 3. Keywords that are subcommand dividers (like `|`) are handled 57 | internally by `cmd`. Otherwise, a keyword, along with the next 58 | value, is used as a keyword argument to UIOP. 59 | 60 | ``` lisp 61 | (cmd "bash -c 'exit 1'" :ignore-error-status t) 62 | ≡ (cmd :ignore-error-status t "bash -c 'exit 1'") 63 | ≡ (cmd :check nil "bash -c 'exit 1'") 64 | ≡ (cmd "bash -c" :ignore-error-status t '("exit 1")) 65 | ≡ (cmd "bash -c" :check nil '("exit 1")) 66 | ``` 67 | 68 | Note that unlike normal Lisp functions, keyword arguments can 69 | appear anywhere, not just at the end. 70 | 71 | Also note `:check` is accepted as an alias for 72 | `:ignore-error-status`, although the value is negated before being 73 | passed to UIOP. 74 | 75 | 4. Any character, integer, or pathname is directly added to the list 76 | of arguments, as if it were an escaped string. (It is an error if a 77 | pathname begins with `-`.) 78 | 79 | 5. Cmd supports a basic form of process substitution, running 80 | processes as input to commands expecting files. To construct a 81 | process substitution, use the `psub` Lisp function. 82 | 83 | ``` lisp 84 | (cmd? "diff" (psub "echo x") (psub "echo x")) 85 | => T 86 | 87 | (cmd? "diff" (psub "echo x") (psub "echo y")) 88 | => NIL 89 | ``` 90 | 91 | (For this specific case, however – passing a string to a command 92 | expecting a file – use `psub-echo` or `psub-format`, which don’t 93 | actually call an external program.) 94 | 95 | ### Parsing the `cmd` DSL 96 | 97 | You can use the `cmd` DSL in your own programs with `cmd:parse-cmd-dsl`. This takes a list of arguments and returns two values: a fully-tokenized list of command arguments and a list of keyword arguments, both suitable for passsing to `uiop:launch-program`. 98 | 99 | ``` lisp 100 | (parse-cmd-dsl '("echo 'hello world' > myfile")) 101 | => ("echo" "hello world"), (:OUTPUT "myfile") 102 | ``` 103 | 104 | ## The external program’s working directory 105 | 106 | Cmd is designed with multi-threaded programs in mind. It always runs 107 | programs with their working directory relative to 108 | [`*default-pathname-defaults*`][dpd]. This is because the OS-level 109 | working directory of a program, on both Windows and Unix, is the working 110 | directory for the entire process, not the individual thread, and 111 | changing it changes it for all threads. 112 | 113 | You can also specify the directory for a particular command with the 114 | keyword argument `:in`: 115 | 116 | ``` lisp 117 | (cmd "ls" :in #p"/") 118 | (cmd :in #p"/" "ls") 119 | => /bin /home /tmp /usr ... 120 | ``` 121 | 122 | For convenience Cmd supplies the macro `with-working-directory`: 123 | 124 | ``` lisp 125 | (with-working-directory (dir) 126 | (cmd ...) 127 | (cmd ...)) 128 | ≡ (progn 129 | (cmd :in dir ...) 130 | (cmd :in dir ...)) 131 | ``` 132 | 133 | ## The external program’s environment 134 | 135 | For Unix users only, the variable `*cmd-env*` holds an alist of extra 136 | environment variables to set for each call to `cmd`. 137 | 138 | ``` lisp 139 | 140 | (let ((*cmd-env* (acons "GIT_PAGER" "cat" *cmd-env*))) 141 | (cmd "git diff" ...)) 142 | ``` 143 | 144 | We are currently very restrictive about what we consider a valid 145 | environment variable name. 146 | 147 | ### Controlling PATH 148 | 149 | For controlling the `PATH` environment variable, the Lisp variable 150 | `*cmd-path*` can be used: 151 | 152 | ``` lisp 153 | (let ((*cmd-path* (cons #p"~/.local/bin" *cmd-path*))) 154 | ...) 155 | ``` 156 | 157 | Directories in `*cmd-path*` are prepended to `PATH`. 158 | 159 | This uses the same mechanism as `*cmd-env*`, so it also only works on 160 | Unix. 161 | 162 | ## Entry points 163 | 164 | The `cmd` package offers several entry points: 165 | 166 | - `cmd` runs an external program synchronously, returning the exit 167 | code. By default, on a non-zero exit it signals an error. 168 | 169 | ```lisp 170 | (cmd "cat /etc/os-release") 171 | NAME="Ubuntu" [...] 172 | => 0 173 | ``` 174 | 175 | - `$cmd` returns the output of the external program as a string, 176 | stripping any trailing newline. (Much like `$(cmd)` in a shell.) The 177 | exit code is returned as a second value. 178 | 179 | ```lisp 180 | ($cmd "date") 181 | => "Sun Sep 27 15:43:01 CDT 2020", 0 182 | ``` 183 | 184 | - `cmd!` runs an external program purely for side effects, discarding 185 | all output and returning nothing. If the program exits non-zero, 186 | however, it will still signal an error. 187 | 188 | - `cmd?` returns `t` if the external program returned `0`, and `nil` 189 | otherwise, with the exit code as a second value. As other variants 190 | by default signal an error if the process exists non-zero, `cmd?` is 191 | useful for programs expected to fail. 192 | 193 | ```lisp 194 | (cmd? "kill -0" pid) 195 | => T, 0 ;; PID is a live process 196 | => NIL, 1 ;; PID is not a live process 197 | ``` 198 | 199 | - `cmd&` runs an external program asynchronously (with 200 | `uiop:launch-program`) and returns a UIOP `process-info` object. 201 | 202 | ```lisp 203 | (cmd& "cp -a" src dest) 204 | => # 205 | ``` 206 | 207 | ## Error handling 208 | 209 | By default, Cmd stores the stderr of a process, and if there is an 210 | error (due to non-zero exit) it presents the stderr as part of the 211 | error message. 212 | 213 | Accordingly `cmd` errors are a subclass of `uiop:subprocess-error`. The 214 | stored stderr can be accessed with `cmd:cmd-error-stderr`. 215 | 216 | ## Redirection 217 | 218 | Redirection is accomplished via either tokenized strings or keyword 219 | arguments. These should be self-explanatory to anyone who has used a 220 | shell. 221 | 222 | ``` lisp 223 | ;;; Using keyword arguments. 224 | (cmd "echo 'hello world'" :> "hello.txt") 225 | (cmd "cat hello.txt") 226 | => hello world 227 | ;; Append 228 | (cmd "echo 'goodbye world'" :>> "hello.txt") 229 | (cmd "cat hello.txt") 230 | => hello world 231 | goodbye world 232 | (cmd "tar cf - hello.txt" :> #p"hello.tar") 233 | (cmd "rm hello.txt") 234 | (cmd "tar xf hello.tar") 235 | (cmd "cat hello.txt") 236 | => hello world 237 | goodbye world 238 | 239 | ;;; Equivalents using tokenized strings. 240 | (cmd "echo 'hello world' > hello.txt") 241 | (cmd "cat hello.txt") 242 | => hello world 243 | ;; Append 244 | (cmd "echo 'goodbye world' >> hello.txt") 245 | (cmd "cat hello.txt") 246 | => hello world 247 | goodbye world 248 | (cmd "tar cf - hello.txt > hello.tar") 249 | (cmd "rm hello.txt") 250 | (cmd "tar xf hello.tar") 251 | (cmd "cat hello.txt") 252 | => hello world 253 | goodbye world 254 | 255 | ``` 256 | 257 | Redirection with keyword arguments is usually more readable when the arguments are computed. 258 | 259 | Supported directions include: 260 | 261 | - `:<` Redirect stdin. 262 | - `:>`, `:1>` Redirect stdout. 263 | - `:>>`, `:1>>` Append stdout. 264 | - `:2>` Redirect stderr. 265 | - `:2>>` Append stderr. 266 | - `:&>`, `:>&` Redirect stdout and stderr. 267 | - `:&>>`, `:>>&` Append stdout and stderr. 268 | - `:<<<` Provide input from a “here string”. 269 | 270 | Note redirections are interpreted according to the rules for Lisp 271 | keywords (only the first occurrence of a keyword argument matters), 272 | not the side-effecting rules for redirections in POSIX shells. 273 | 274 | ### Pipelines 275 | 276 | The simplest way to set up pipelines is to use tokenized strings: 277 | 278 | ``` lisp 279 | (cmd "cat /usr/share/dict/words | sort | uniq -c | sort -nrs | head -3") 280 | => 1 a 281 | 1 A 282 | 1 Aachen 283 | ``` 284 | 285 | Alternately you can use keywords. While `:|\||` is acceptable, you can write `"|"` instead. (Remember `"|"` will be tokenized to `'(:|\||)`.) 286 | 287 | ``` lisp 288 | (cmd "cat /usr/share/dict/words" 289 | "|" '("sort") 290 | "|" '("uniq" "-c") 291 | "|" '("sort" "-nrs") 292 | "|" '("head" "-3")) 293 | => 1 a 294 | 1 A 295 | 1 Aachen 296 | ``` 297 | 298 | Again, separating out the pipeline symbols is usually more readable when the subcommands are computed. 299 | 300 | ## Controlling cmd with hooks 301 | 302 | There are two hooks you can use to control `cmd`. These are exported from the `cmd/hooks` package (so you can `:use :cmd` without having to worry about them.) Both hooks expect a list of functions of one argument. 303 | 304 | The hook `*message-hook*` is called with the external program and its arguments, quoted as a shell command line. This can be useful for logging commands as they are run. 305 | 306 | The hook `*proc-hook*` is called with the process object (as returned by `uiop:launch-program`). This can be useful if you want to be able to track what is being run in a particular dynamic extent. 307 | 308 | ## Windows 309 | 310 | On Windows only, the first argument (the program name) has `.exe` appended to it automatically if it doesn’t already have a file extension. 311 | 312 | ## Efficiency 313 | 314 | While `cmd` does not use a shell to interpret its arguments, it may still have to run a shell (`sh` on Unix, `cmd.exe` on Windows) in order to change the working directory of the program. 315 | 316 | How inefficient this is depends on what your distribution uses as `/bin/sh`; it is faster when `/bin/sh` is, say, `dash`, than when it is `bash`. 317 | 318 | Recent versions of GNU `env` support a `-C` switch to do this directly. When support is detected dynamically, then `env -C` is used in place of a shell and overhead is negligible. 319 | 320 | ## Past 321 | 322 | Cmd is a spinoff of [Overlord][], a Common Lisp build system, and was 323 | inspired by the `cmd` function in [Shake][], a Haskell build system, 324 | as well as the [Julia][] language’s [shell command 325 | facility][backtick]. The `psub` function is inspired by the 326 | [builtin][psub] of the same name in the [Fish shell][]. 327 | 328 | ## Future 329 | 330 | - Pipelines should have “pipefail” behavior. 331 | - Pipelines should support stderr as well (`2|`, `&|`). 332 | - Efferent process substitution should also be supported. 333 | - There should be a special variable holding an alist of extra 334 | environment variables to set when running a command. (The problem 335 | here is Windows.) 336 | 337 | [UIOP]: https://common-lisp.net/project/asdf/uiop.html 338 | [Overlord]: https://github.com/ruricolist/overlord 339 | [Shake]: https://shakebuild.com/ 340 | [cl-shlex]: https://github.com/ruricolist/cl-shlex 341 | [dpd]: http://clhs.lisp.se/Body/v_defaul.htm 342 | [Bernstein chaining]: http://www.catb.organization/~eser/writings/taoup/html/ch06s06.html 343 | [Julia]: https://julialang.org 344 | [backtick]: https://julialang.org/blog/2013/04/put-this-in-your-pipe/ 345 | [Fish shell]: https://fishshell.com 346 | [psub]: https://fishshell.com/docs/current/cmds/psub.html 347 | -------------------------------------------------------------------------------- /cmd.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cmd/cmd 2 | (:nicknames #:cmd) 3 | (:use #:cl #:alexandria #:serapeum #:cmd/hooks) 4 | (:import-from 5 | :uiop 6 | :delete-file-if-exists 7 | :process-info-input 8 | :process-info-error-output 9 | :process-info-output 10 | :process-info-pid 11 | :pathname-equal 12 | :getcwd 13 | :os-unix-p 14 | :native-namestring 15 | :native-namestring 16 | :os-windows-p :file-exists-p :getenv 17 | :pathname-directory-pathname 18 | :absolute-pathname-p 19 | :directory-pathname-p 20 | :ensure-directory-pathname 21 | :directory-exists-p) 22 | (:import-from :trivia :match :ematch) 23 | (:import-from :shlex) 24 | (:import-from :uiop/launch-program 25 | :process-info) 26 | (:import-from #:trivial-garbage 27 | #:make-weak-hash-table) 28 | (:export 29 | :cmd :$cmd :cmd? :cmd! :cmd& 30 | :sh :$sh :sh? :sh! :sh& 31 | :parse-cmd-dsl 32 | :with-cmd-dir 33 | :with-working-directory 34 | :current-directory 35 | :psub 36 | :psub-echo 37 | :psub-format 38 | :*shell* 39 | :*visual-commands* 40 | :*command-wrappers* 41 | :*terminal* 42 | :vterm-terminal 43 | :*cmd-env* 44 | :*cmd-path* 45 | :*null-output* 46 | :*null-error-output* 47 | :cmd-error 48 | :cmd-error-stderr)) 49 | (in-package :cmd) 50 | 51 | ;;; External executables, isolated for Guix compatibility. 52 | (def +env+ "env") 53 | (def +kill+ "kill") 54 | (def +ps+ "ps") 55 | (def +pwd+ "pwd") 56 | (def +sh+ "/bin/sh") 57 | (def +tr+ "tr") 58 | 59 | (defparameter *null-output* nil 60 | "Null device for standard output. 61 | 62 | By binding this variable you can redirect output that would otherwise 63 | be sent to the null device.") 64 | 65 | (defparameter *null-error-output* nil 66 | "Null device for standard error. 67 | 68 | By binding this variable you can redirect error output that would 69 | otherwise be sent to the null device. 70 | 71 | Note that when error output is not specifically redirected, this 72 | variable is bound to a stream that stashes stderr output for error 73 | reporting.") 74 | 75 | (defvar *shell* 76 | (let ((shell (getenv "SHELL"))) 77 | (if (emptyp shell) 78 | (if (os-unix-p) 79 | +sh+ 80 | "cmd.exe") 81 | shell)) 82 | "The shell to use for shell commands. 83 | 84 | Defaults to $SHELL.") 85 | 86 | (declaim (type (soft-list-of cons) *cmd-env*)) 87 | (defvar *cmd-env* '() 88 | "Alist of extra environment variables.") 89 | 90 | (declaim (type (soft-list-of (or pathname string)) *cmd-path*)) 91 | (defvar *cmd-path* '() 92 | "Extra directories to check for executables.") 93 | 94 | (defun cmd-env (&aux (env *cmd-env*) (path-list *cmd-path*)) 95 | (assert (every #'absolute-pathname-p path-list)) 96 | (let* ((old-path-list 97 | (split-sequence #\: (uiop:getenv "PATH"))) 98 | (new-path-list 99 | (mapcar #'native-namestring path-list)) 100 | (path-env 101 | (and new-path-list 102 | (not (subsetp new-path-list 103 | old-path-list 104 | :test #'equal)) 105 | (cons "PATH" 106 | (fmt "~{~a~^:~}" 107 | (nub (append new-path-list old-path-list))))))) 108 | (declare (type (soft-list-of string) old-path-list new-path-list)) 109 | (if path-env 110 | (cons path-env env) 111 | env))) 112 | 113 | (defun wrap-cmd-env (cmd &aux (env (cmd-env))) 114 | (if (null env) cmd 115 | (if (not (os-unix-p)) 116 | (progn 117 | (cerror "Run without the extra environment variables" 118 | "Cannot use ~s, not on Unix." 119 | '*cmd-env*) 120 | cmd) 121 | `(,+env+ ,@(loop for (k . v) in env 122 | collect (fmt "~a=~a" 123 | (validate-env-var k) 124 | v)) 125 | ,@cmd)))) 126 | 127 | (-> validate-env-var (string-designator) string) 128 | (defun validate-env-var (name) 129 | "Check that NAME is a valid (portable) name for an environment 130 | variable." 131 | (let ((name (string name))) 132 | (if (and (every (lambda (char) 133 | (or (eql char #\_) 134 | (digit-char-p char 10) 135 | (and (alpha-char-p char) 136 | (ascii-char-p char)) 137 | (find char "!%,@"))) 138 | name) 139 | (or (emptyp name) 140 | (not (digit-char-p (aref name 0) 10)))) 141 | name 142 | (error "Bad name for an environment variable: ~a" name)))) 143 | 144 | (-> resolve-dir ((or string pathname)) 145 | (values absolute-directory-pathname &optional)) 146 | (defun resolve-dir (dir) 147 | "Resolve DIR into an absolute directory based on 148 | `*default-pathname-defaults*`, supplemented with the OS-level working 149 | directory if that is not absolute." 150 | (let ((dir (ensure-directory-pathname dir))) 151 | (if (typep dir 'absolute-pathname) dir 152 | (ensure-directory-pathname 153 | (if (typep *default-pathname-defaults* 'absolute-pathname) 154 | (path-join *default-pathname-defaults* dir) 155 | (path-join (uiop:getcwd) 156 | *default-pathname-defaults* 157 | dir)))))) 158 | 159 | (-> current-directory () (values absolute-directory-pathname &optional)) 160 | (defun current-directory () 161 | "Get the absolute current directory based on `*default-pathname-defaults*'." 162 | (resolve-dir *default-pathname-defaults*)) 163 | 164 | (-> (setf current-directory) (pathname) 165 | (values absolute-directory-pathname &optional)) 166 | (defun (setf current-directory) (value) 167 | (setf *default-pathname-defaults* 168 | (assure absolute-directory-pathname 169 | (resolve-dir value)))) 170 | 171 | (defun can-use-env-c? () 172 | "Return T if we can use env -C to launch a program in the current 173 | directory, instead of using a shell." 174 | (and (os-unix-p) 175 | (zerop 176 | (nth-value 2 177 | (uiop:run-program 178 | `(,+env+ "-C" 179 | ,(native-namestring 180 | (user-homedir-pathname)) 181 | "pwd") 182 | :ignore-error-status t 183 | :output nil 184 | :error-output nil))))) 185 | 186 | (defparameter *can-use-env-c* 187 | (can-use-env-c?) 188 | "Save whether we can use env -C.") 189 | 190 | (defun update-can-use-env-c () 191 | (setf *can-use-env-c* (can-use-env-c?))) 192 | 193 | (uiop:register-image-restore-hook 'update-can-use-env-c) 194 | 195 | (defconst +redirection-operators+ 196 | '(:< :> :<> :1> :>> :1>> :|>\|| :2> :2>> :|2>\|| :&> :>& :&>> :>>& :<<< :>? :2>?) 197 | "All redirection operators that can be parsed in tokenized strings.") 198 | 199 | (defconst +subcommand-dividers+ 200 | ;; TODO &&, ||, etc. 201 | '(:|\||) 202 | "All supported subcommand dividers (e.g. pipelines).") 203 | 204 | (deftype redirection-operator () 205 | '#.(cons 'member +redirection-operators+)) 206 | 207 | (deftype subcommand-divider () 208 | '#.(cons 'member +subcommand-dividers+)) 209 | 210 | (defconstructor string-token 211 | (string (simple-array character (*)))) 212 | 213 | (defun make-string-token (string) 214 | (string-token (coerce string '(simple-array character (*))))) 215 | 216 | (defun flatten-string-tokens (list) 217 | (mapcar (lambda (item) 218 | (if (typep item 'string-token) 219 | (string-token-string item) 220 | item)) 221 | list)) 222 | 223 | (deftype parseable () 224 | '(or keyword string list 225 | string-token substitution subcommand-divider 226 | integer character pathname)) 227 | 228 | (defun expand-redirection-abbrev (keyword) 229 | (assure list 230 | (case-of (or (eql :in) redirection-operator) keyword 231 | (:in '(:directory _)) 232 | (:< '(:input _)) 233 | ((:> :1>) '(:output _)) 234 | ((:<>) '(:input _ :output _)) 235 | ((:>> :1>>) '(:if-output-exists :append :output _)) 236 | (:|>\|| '(:if-output-exists :supersede :output _)) 237 | (:2> '(:error-output _)) 238 | (:2>> '(:if-error-output-exists :append :error-output _)) 239 | (:|2>\|| '(:if-error-output-exists :supersede :error-output _)) 240 | ((:&> :>&) '(:output _ :error-output _)) 241 | ((:&>> :>>&) '(:if-error-output-exists :append 242 | :if-output-exists :append 243 | :error-output _ 244 | :output _)) 245 | (:>? '(:if-output-exists :error :output _)) 246 | (:2>? '(:if-error-output-exists :error :error-output _)) 247 | (:<<< '(:<<< _)) 248 | (otherwise nil)))) 249 | 250 | (def +dividers+ '(:|\||)) 251 | 252 | (defun expand-keyword-aliases (args) 253 | (collecting 254 | (doplist (k v args) 255 | (let ((exp (expand-redirection-abbrev k))) 256 | (cond (exp 257 | (apply #'collect (substitute v '_ exp))) 258 | ((eql k :check) 259 | (collect :ignore-error-status (not v))) 260 | (t (collect k v))))))) 261 | 262 | (defun call/cmd-dir (fn dir) 263 | (let* ((*default-pathname-defaults* (resolve-dir dir))) 264 | (funcall fn))) 265 | 266 | (defmacro with-working-directory ((dir) &body body) 267 | "Run BODY with DIR as the current directory. 268 | Calls to `cmd' and its variants with the dynamic extent of the 269 | `with-working-directory' form will use `dir' as their working directory." 270 | (with-thunk (body) 271 | `(call/cmd-dir ,body ,dir))) 272 | 273 | (defmacro with-cmd-dir (dir &body body) 274 | "Deprecated; use `with-working-directory' instead." 275 | (simple-style-warning "~s is deprecated, please use ~s" 276 | 'with-cmd-dir 277 | 'with-working-directory) 278 | (with-thunk (body) 279 | `(call/cmd-dir ,body ,dir))) 280 | 281 | (defvar *visual-commands* '() 282 | "List of commands that should be run in a `*terminal*' emulator. 283 | Also see `*command-wrappers*'.") 284 | 285 | (defvar *command-wrappers* '("sudo" "env") 286 | "Commands that fire up other commands. 287 | This list is used by `visual-command-p' to check if the wrapped command is a 288 | visual one. 289 | See `*visual-commands*'.") 290 | 291 | (defun visual-command-p (command) 292 | "Return true if the COMMAND list runs one of the programs in `*visual-commands*'. 293 | `*command-wrappers*' are supported, i.e. 294 | 295 | env FOO=BAR sudo -i powertop 296 | 297 | works." 298 | (setf command (flatten-string-tokens command)) 299 | (labels ((basename (arg) 300 | (when-let (name (pathname-name arg)) 301 | (namestring name))) 302 | (flag? (arg) 303 | (string^= "-" arg)) 304 | (variable? (arg) 305 | (and (< 1 (length arg)) 306 | (string*= "=" (subseq arg 1)))) 307 | (first-positional-argument (command) 308 | "Return the argument that's not a flag, not a variable setting and 309 | not in `*command-wrappers*'." 310 | (when command 311 | (if (or (flag? (first command)) 312 | (variable? (first command)) 313 | (when-let (basename (basename (first command))) 314 | (find basename 315 | *command-wrappers* 316 | :test #'string=))) 317 | (first-positional-argument (rest command)) 318 | (first command))))) 319 | (and-let* ((cmd (first-positional-argument command))) 320 | (find (basename cmd) 321 | *visual-commands* 322 | :test #'string=)))) 323 | 324 | (defun vterm-terminal (cmd) 325 | "Run visual command CMD in Emacs' `vterm'." 326 | (list 327 | "emacsclient" "--eval" 328 | (let ((*package* (find-package :cmd/cmd))) 329 | (write-to-string 330 | `(progn 331 | (vterm) 332 | (vterm-insert ,(string-join (flatten-string-tokens cmd) " ")) 333 | (vterm-send-return)) 334 | :case :downcase)))) 335 | 336 | (defvar *terminal* (cond 337 | ((resolve-executable "xterm") 338 | '("xterm" "-e")) 339 | ((resolve-executable "emacs") 340 | #'vterm-terminal)) 341 | "The terminal is either 342 | - a list of arguments after which the visual command is appended, 343 | - or a function of one argument, the list of commands, returning the new list of 344 | commands. 345 | See `*visual-commands*'.") 346 | 347 | (defun maybe-visual-command (cmd) 348 | (if (visual-command-p cmd) 349 | (if (functionp *terminal*) 350 | (funcall *terminal* cmd) 351 | (append *terminal* cmd)) 352 | cmd)) 353 | 354 | (defvar *subprocs* 355 | (make-weak-hash-table :weakness :key) 356 | "A table from process to subprocesses.") 357 | 358 | (defun subprocs (proc) 359 | (synchronized ('*subprocs*) 360 | (gethash proc *subprocs*))) 361 | 362 | (defun (setf subprocs) (value proc) 363 | (check-type value list) 364 | (synchronized ('*subprocs*) 365 | (setf (gethash proc *subprocs*) value))) 366 | 367 | (defun register-subproc (proc subproc) 368 | "Register SUBPROC as a subprocess of PROC and return SUBPROC." 369 | (register-subprocs proc subproc) 370 | (values)) 371 | 372 | (defun register-subprocs (proc &rest subprocs) 373 | "Register SUBPROC as a subprocess of PROC." 374 | (synchronized ('*subprocs*) 375 | (unionf (subprocs proc) subprocs) 376 | (values))) 377 | 378 | (defun kill-subprocs (proc &key urgent) 379 | "Kill all subprocesses of PROC." 380 | (synchronized ('*subprocs*) 381 | (dolist (subproc (subprocs proc)) 382 | (etypecase subproc 383 | ;; Arbitrary cleanup. 384 | (function (funcall subproc)) 385 | (process-info 386 | (kill-subprocs subproc :urgent urgent) 387 | (kill-process-group subproc :urgent urgent)))) 388 | (remhash proc *subprocs*))) 389 | 390 | (defcondition cmd-error (uiop:subprocess-error) 391 | ((stderr :initarg :stderr :type string :reader cmd-error-stderr)) 392 | (:default-initargs :stderr "") 393 | (:report (lambda (c s) 394 | (format s "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]~@[~2%=== ERROR OUTPUT ===~%~a~]" 395 | (uiop:subprocess-error-process c) 396 | (uiop:subprocess-error-command c) 397 | (uiop:subprocess-error-code c) 398 | (let ((stderr (cmd-error-stderr c))) 399 | (unless (emptyp stderr) 400 | (ellipsize stderr 10000))))))) 401 | 402 | (defun get-stderr-output-stream-string (s) 403 | "Get output from S. 404 | Note this will only be called if an error is signaled." 405 | (finish-output s) 406 | (let* ((end (file-position s)) 407 | (seq (make-array end :element-type (stream-element-type s)))) 408 | (file-position s 0) 409 | (read-sequence seq s) 410 | (prog1 seq 411 | (ignore-errors 412 | (close s))))) 413 | 414 | (defun call/stderr-file (fn) 415 | (uiop:with-temporary-file (:pathname p :keep nil) 416 | (with-open-file (s p 417 | :direction :io 418 | :element-type 'character 419 | :allow-other-keys t 420 | :if-exists :overwrite 421 | ;; For CCL. 422 | :sharing :external) 423 | #-windows (delete-file p) 424 | (handler-bind ((uiop:subprocess-error 425 | (lambda (c) 426 | (error 427 | 'cmd-error 428 | :process (uiop:subprocess-error-process c) 429 | :command (uiop:subprocess-error-command c) 430 | :code (uiop:subprocess-error-code c) 431 | :stderr (get-stderr-output-stream-string s))))) 432 | (funcall fn s))))) 433 | 434 | (defmacro with-stderr-file ((var &key) &body body) 435 | (with-thunk (body var) 436 | `(call/stderr-file ,body))) 437 | 438 | (defmacro with-stderr-caching ((&key) &body body) 439 | (with-thunk (body) 440 | `(if *null-error-output* 441 | (funcall ,body) 442 | (with-stderr-file (*null-error-output*) 443 | (,body))))) 444 | 445 | (defmacro define-cmd-variant (name sh-name lambda-list &body body) 446 | (let ((docstring (and (stringp (car body)) (pop body)))) 447 | `(progn 448 | (defun ,name ,lambda-list 449 | ,@(unsplice docstring) 450 | (with-stderr-caching () 451 | ,@body)) 452 | (define-compiler-macro ,name (cmd &rest args) 453 | `(locally (declare (notinline ,',name)) 454 | (,',name ,@(simplify-cmd-args (cons cmd args))))) 455 | (defun ,sh-name (cmd &rest kwargs &key &allow-other-keys) 456 | ,(fmt "Like `~(~a~)' for a shell command. 457 | 458 | Takes a single argument (along with keyword arguments for redirection) 459 | and passes it to a shell. 460 | 461 | The shell defaults to the value of `cmd:*shell*' (which in turn 462 | defaults to the value of SHELL in the environment)." 463 | name) 464 | (apply #'as-shell #',name cmd kwargs))))) 465 | 466 | (defun shell-arg () 467 | ;; NB Even Powershell supports -c. 468 | (if (equal *shell* "cmd.exe") "/c" "-c")) 469 | 470 | ;; Inline so it propagates the ftype. 471 | (defsubst as-shell (fn cmd &rest kwargs &key &allow-other-keys) 472 | (declare (function fn) (string cmd)) 473 | (apply fn *shell* (shell-arg) (list cmd) kwargs)) 474 | 475 | (defclass cmd () 476 | ((argv :reader cmd-argv) 477 | ;; Currently mutable for the :<<< hack. 478 | (kwargs :accessor cmd-kwargs)) 479 | (:documentation "A single subcommand, with argv and kwargs ready to 480 | pass to `uiop:launch-program'.")) 481 | 482 | (defclass substitution () 483 | () 484 | (:documentation "A command substitution.")) 485 | 486 | (defgeneric launch-substitution (sub) 487 | (:documentation "Launch a command substitution. 488 | Should always return two values, both lists: 489 | 1. A list of new arguments for the argv. 490 | 2. A list of cleanup forms.")) 491 | 492 | (defclass psub-echo (substitution) 493 | ((string :initarg :string :reader psub-echo-string :type string)) 494 | (:documentation "A process substitution that just echoes a string.") 495 | (:default-initargs 496 | :string (error "No string!"))) 497 | 498 | (defun psub-echo (string) 499 | "Allow passing STRING to a command that expects a file. 500 | This is practically equivalent to 501 | 502 | (psub \"echo\" (list string)) 503 | 504 | Except that it doesn't actually launch an external program." 505 | (check-type string string) 506 | (make 'psub-echo :string string)) 507 | 508 | (defun psub-format (control-string &rest args) 509 | "Format ARGS using CONTROL-STRING and pass the result as a file to 510 | the enclosing command. 511 | 512 | This is practically equivalent to 513 | 514 | (psub \"echo\" (list (format nil \"?\" control-string args)) 515 | 516 | Except that it doesn't actually launch an external program." 517 | (declare (dynamic-extent args)) 518 | (psub-echo (fmt "~?" control-string args))) 519 | 520 | (define-compiler-macro psub-format (&whole call control-string &rest args) 521 | (if (stringp control-string) 522 | `(psub-format (formatter ,control-string) ,@args) 523 | call)) 524 | 525 | (defmethod launch-substitution ((sub psub-echo)) 526 | (let ((temp (mktemp))) 527 | (write-string-into-file (psub-echo-string sub) 528 | temp 529 | :if-exists :rename 530 | :if-does-not-exist :create) 531 | (values (list (stringify-pathname temp)) 532 | (list (lambda () (delete-file-if-exists temp)))))) 533 | 534 | (defclass psub (substitution cmd) () 535 | (:documentation "A process substitution.")) 536 | 537 | (defmethod print-object ((self cmd) stream) 538 | (print-unreadable-object (self stream :type t) 539 | (with-slots (argv kwargs) self 540 | (format stream "~a ~s" argv kwargs))) 541 | self) 542 | 543 | (defmethod initialize-instance :after ((self cmd) &key 544 | ((:argv raw-argv) nil) 545 | ((:kwargs short-kwargs) nil)) 546 | (assert (evenp (length short-kwargs))) 547 | (when (null raw-argv) 548 | (error "No argv!")) 549 | (with-slots (argv kwargs) self 550 | (setf argv 551 | ;; NB UIOP expects simple-strings for arguments. 552 | (maybe-visual-command 553 | (and raw-argv 554 | (cons (exe-string (car raw-argv)) 555 | (cdr raw-argv)))) 556 | kwargs (expand-keyword-aliases short-kwargs)))) 557 | 558 | (defmethod launch-substitution ((arg psub)) 559 | (let ((temp (mktemp))) 560 | (values 561 | (list (stringify-pathname temp)) 562 | (list (lambda () (delete-file-if-exists temp)) 563 | (launch-cmd arg :output temp :error-output nil))))) 564 | 565 | (defun parse-cmd (args) 566 | (receive (argv kwargs) (argv+kwargs args) 567 | (make 'cmd :argv argv :kwargs kwargs))) 568 | 569 | (defun parse-cmd-dsl (command) 570 | "Parse COMMAND like `cmd' does. 571 | Returns two values: the fully tokenized command, and a list of 572 | redirection arguments (in the format expected by 573 | `uiop:launch-program'). 574 | 575 | This can be used to write your own functions that support the `cmd' DSL." 576 | (check-type command list) 577 | (let ((cmd (parse-cmd command))) 578 | (values (flatten-string-tokens (cmd-argv cmd)) 579 | (flatten-string-tokens (cmd-kwargs cmd))))) 580 | 581 | (defun split-pipeline (args) 582 | "Split ARGS into two values: the last command in the pipeline, and any previous commands." 583 | (let* ((args (parse-cmd-args args)) 584 | (tail args)) 585 | (loop for new-tail = (member :|\|| tail) 586 | while new-tail 587 | do (setf tail (rest new-tail))) 588 | (values tail 589 | (ldiff args tail)))) 590 | 591 | (-> stage-pipeline (list) (values cmd &optional)) 592 | (defun stage-pipeline (cmds) 593 | "Return CMDS as a single command that can be passed to `launch-pipeline'." 594 | (reduce (lambda (outer inner) 595 | (make 'cmd 596 | :argv (cmd-argv outer) 597 | :kwargs (list* :output inner (cmd-kwargs outer)))) 598 | cmds 599 | :from-end t)) 600 | 601 | (-> cmdq (&rest t) (values cmd &optional)) 602 | (define-cmd-variant cmdq shq (cmd &rest args) 603 | (parse-cmd (cons cmd args))) 604 | 605 | (-> psub (&rest t) (values psub &optional)) 606 | (define-cmd-variant psub psub-shell (cmd &rest args) 607 | (receive (argv kwargs) (argv+kwargs (cons cmd args)) 608 | (make 'psub :argv argv :kwargs kwargs))) 609 | 610 | (-> get-tmpfs () 611 | (values (or null absolute-directory-pathname) &optional)) 612 | (defun get-tmpfs () 613 | "Get a suitable tmpfs." 614 | (declare (notinline $cmd)) ;Bootstrapping. 615 | (when (os-unix-p) 616 | (or (let ((dir (getenv "XDG_RUNTIME_DIR"))) 617 | (unless (emptyp dir) 618 | (ensure-directory-pathname dir))) 619 | (or (directory-exists-p 620 | (make-pathname 621 | :directory `(:absolute 622 | "run" 623 | "user" 624 | ,($cmd "id -u")))) 625 | (directory-exists-p #P"/run/shm") 626 | (directory-exists-p #P"/dev/shm"))))) 627 | 628 | (defun mktemp () 629 | "Create a temporary file for use with process substition. 630 | When possible use a tmpfs." 631 | (let ((uiop:*temporary-directory* 632 | (or (get-tmpfs) uiop:*temporary-directory*))) 633 | (uiop:with-temporary-file (:pathname p :keep t :prefix "cmd") 634 | p))) 635 | 636 | (defun launch-psubs (argv) 637 | "Launch any process substitutions in ARGV. Return two values: the 638 | new argv and a list of subprocesses (or other cleanup forms)." 639 | (with-collectors (new-argv cleanup) 640 | (dolist (arg argv) 641 | (if (typep arg 'substitution) 642 | (receive (new-args cleanups) 643 | (launch-substitution arg) 644 | (mapc #'new-argv new-args) 645 | (mapc #'cleanup cleanups)) 646 | (new-argv arg))))) 647 | 648 | (defun launch-cmd (cmd &rest overrides &key &allow-other-keys) 649 | "Auxiliary function for launching CMD with overrides." 650 | (multiple-value-call #'cmd& 651 | (values-list (cmd-argv cmd)) 652 | (values-list overrides) 653 | (values-list (cmd-kwargs cmd)))) 654 | 655 | (-> $cmd (&rest t) (values string integer &optional)) 656 | (define-cmd-variant $cmd $sh (cmd &rest args) 657 | "Return the results of CMD as a string, stripping any trailing 658 | newlines, like $(cmd) would in a shell. 659 | 660 | As a second value, return the error status. 661 | 662 | By default stderr is discarded." 663 | (let* ((exit-code) 664 | (string 665 | (chomp 666 | (with-output-to-string (s) 667 | (receive (final subs) 668 | (split-pipeline (cons cmd args)) 669 | (setf exit-code 670 | (multiple-value-call #'cmd 671 | (values-list subs) 672 | :output s 673 | (values-list final) 674 | :error-output *null-error-output*))))))) 675 | (values string exit-code))) 676 | 677 | (-> cmd? (&rest t) (values boolean integer &optional)) 678 | (define-cmd-variant cmd? sh? (cmd &rest args) 679 | "Run a program, returning T if it passed, nil otherwise. 680 | By default the output is discarded. 681 | 682 | Returns the actual exit code as a second value." 683 | (mvlet* ((final subs (split-pipeline (cons cmd args))) 684 | (exit-code 685 | (multiple-value-call #'cmd 686 | (values-list subs) 687 | :ignore-error-status t 688 | (values-list final) 689 | :output nil 690 | :error-output nil))) 691 | (if (zerop exit-code) 692 | (values t 0) 693 | (values nil exit-code)))) 694 | 695 | (-> cmd! (&rest t) (values &optional)) 696 | (define-cmd-variant cmd! sh! (cmd &rest args) 697 | "Run CMD purely for its side effects, discarding all output and returning nothing." 698 | (receive (final subs) (split-pipeline (cons cmd args)) 699 | (multiple-value-call #'cmd 700 | (values-list subs) 701 | :output nil 702 | :error-output nil 703 | (values-list final))) 704 | (values)) 705 | 706 | (-> cmd (&rest t) (values integer &optional)) 707 | (define-cmd-variant cmd sh (cmd &rest args) 708 | "Run a program. 709 | 710 | CMD should be a string naming a program. This command will be run with 711 | its current directory set to the value of the current directory in a 712 | thread-safe manner. 713 | 714 | The current directory is based on `*default-pathname-defaults*', not on the OS-level working directory, as the OS-level directory is useless for multi-threaded programs. 715 | 716 | A list of strings or pathnames is added to the list of arguments. 717 | 718 | A string in ARGS is split into a list of tokens using shell-style 719 | tokenization rules. (To protect a string with spaces, either add 720 | quotation marks, or enclose it in a singleton list.) 721 | 722 | A pathname in ARGS is translated to a native namestring and passed as 723 | an argument to the command. The native namestring is not permitted to 724 | start with a dash. 725 | 726 | A property list is treated as a list of keyword arguments to 727 | `uiop:launch-program'. Certain keywords are treated as abbreviations: 728 | e.g. `:>' is an abbreviation for `:output'. Abbreviations can be 729 | compound: e.g. `:>>' affects both `:output' and `:if-exists'. 730 | 731 | By default, standard output is sent to `*standard-output*', and error 732 | output is sent to `*message-stream*'. 733 | 734 | On Windows, the .exe suffix may be omitted from the name of the 735 | executable." 736 | (receive (proc tokens args) (apply #'cmd& cmd args) 737 | (await proc 738 | :ignore-error-status (getf args :ignore-error-status) 739 | :tokens tokens))) 740 | 741 | (eval-always 742 | (defun simplify-cmd-args (args) 743 | "Simplify ARGS at compile time (for compiler macros)." 744 | (nlet rec ((args-in args) 745 | (args-out '())) 746 | (match args-in 747 | ((list) 748 | (reverse args-out)) 749 | ((list (and _ (type keyword))) 750 | (error "Dangling keyword argument to cmd.")) 751 | ((list* (and k (type keyword)) v rest) 752 | (rec rest 753 | (cons (if (constantp v) 754 | `'(,k ,v) 755 | `(list ,k ,v)) 756 | args-out))) 757 | ((list* (and x (type parseable)) xs) 758 | (etypecase-of parseable x 759 | (string 760 | (let ((tokens (split-cmd x))) 761 | (rec xs 762 | ;; A subtlety: an argument after a literal keyword 763 | ;; (that is not a subcommand divider) is not 764 | ;; parsed, but an argument after a string that 765 | ;; parses as a keyword is itself parsed. To 766 | ;; preserve that behavior we can't expand at 767 | ;; runtime if the last token is a keyword. 768 | (if (typep (lastcar tokens) 'keyword) 769 | (cons x args-out) 770 | (revappend tokens args-out))))) 771 | (pathname 772 | (rec xs 773 | (cons (make-string-token (stringify-pathname x)) 774 | args-out))) 775 | (integer 776 | (rec xs 777 | (cons (make-string-token (princ-to-string x)) 778 | args-out))) 779 | (character 780 | (rec xs 781 | (cons (make-string-token (string x)) 782 | args-out))) 783 | ((or subcommand-divider keyword list 784 | string-token substitution) 785 | (rec xs (cons x args-out))))) 786 | ((list* x xs) 787 | (rec xs (cons x args-out))))))) 788 | 789 | (-> cmd& (&rest t) (values process-info list list &optional)) 790 | (define-cmd-variant cmd& sh& (cmd &rest args) 791 | "Like `cmd', but run asynchronously and return a handle on the process (as from `launch-program')." 792 | (mvlet* ((final subs (split-pipeline (cons cmd args))) 793 | (final (parse-cmd final)) 794 | (subs (mapcar #'cmdq (split-sequence :|\|| subs :remove-empty-subseqs t))) 795 | (pipeline (append1 subs final))) 796 | (when *message-hook* 797 | (run-hook *message-hook* 798 | (fmt "$ ~{~{~a~^ ~}~^ | ~}" 799 | (mapcar (op (mapcar #'shlex:quote _)) 800 | (flatten-string-tokens 801 | (mapcar #'cmd-argv pipeline)))))) 802 | (flet ((launch () 803 | (let* ((cmd (stage-pipeline pipeline)) 804 | (argv (flatten-string-tokens (cmd-argv cmd))) 805 | (kwargs (flatten-string-tokens (cmd-kwargs cmd)))) 806 | (values 807 | (apply #'launch-pipeline 808 | argv 809 | kwargs) 810 | argv 811 | kwargs)))) 812 | (if-let (here-string (getf (cmd-kwargs final) :<<<)) 813 | (with-input-from-string (in here-string) 814 | (symbol-macrolet ((args (cmd-kwargs final))) 815 | (setf args 816 | (let* ((suffix (member :<<< args)) 817 | (prefix (ldiff args suffix))) 818 | (append prefix 819 | (list :input in) 820 | (cddr suffix))))) 821 | (launch)) 822 | (launch))))) 823 | 824 | (defun launch-pipeline (argv &rest args) 825 | ;; TODO Need an equivalent to pipefail. Checking the process exit 826 | ;; codes won't work; on SBCL at least, in a pipeline the exit status 827 | ;; is apparently always 0. 828 | (destructuring-bind (&key input 829 | (output *standard-output*) 830 | (error-output 831 | (make-broadcast-stream 832 | ;; Stash stderr output for error reporting. 833 | *null-error-output* 834 | *error-output*)) 835 | &allow-other-keys) args 836 | (mvlet* ((prev (and (typep input 'cmd) 837 | (launch-cmd input :output :stream))) 838 | (argv psubs (launch-psubs argv)) 839 | (proc (multiple-value-call #'launch-program-in-dir* 840 | argv 841 | (if prev 842 | (values :input (process-info-output prev)) 843 | (values)) 844 | (if (typep output 'cmd) 845 | (values :output :stream) 846 | (values)) 847 | (if (typep error-output 'cmd) 848 | (values :error-output :stream) 849 | (values)) 850 | (values-list args) 851 | :output output 852 | :error-output error-output))) 853 | (apply #'register-subprocs proc psubs) 854 | (when prev 855 | (register-subproc proc prev)) 856 | (cond 857 | ((and (typep output 'cmd) 858 | (typep error-output 'cmd)) 859 | (error "Not implemented yet")) 860 | ((typep output 'cmd) 861 | (lret ((next (launch-cmd output :input (process-info-output proc)))) 862 | (register-subproc next proc))) 863 | ((typep error-output 'cmd) 864 | (lret ((enext (launch-cmd error-output :input (process-info-error-output proc)))) 865 | (register-subproc enext proc))) 866 | (t proc))))) 867 | 868 | (defun launch-program-in-dir* (tokens &rest args) 869 | "Run a program (with `uiop:launch-program') in the current base directory." 870 | (let ((dir (stringify-pathname 871 | (or (getf args :directory) 872 | (current-directory))))) 873 | (apply #'launch-program-in-dir dir tokens 874 | (remove-from-plist args :directory)))) 875 | 876 | (defun override-default-output-and-error-output (args) 877 | "Override null output with `*null-output*' and null error output 878 | with `*null-error-output*'." 879 | (destructuring-bind (&key output error-output &allow-other-keys) args 880 | (append 881 | (and (null output) 882 | `(:output ,*null-output*)) 883 | (and (null error-output) 884 | `(:error-output ,*null-error-output*)) 885 | args))) 886 | 887 | (defun launch-program-in-dir (dir tokens 888 | &rest args 889 | &key 890 | &allow-other-keys) 891 | (let* ((cmd 892 | (wrap-cmd-env 893 | ;; NB The :directory argument to launch-program may end up 894 | ;; calling `chdir', which is unacceptable. 895 | (wrap-with-dir dir tokens))) 896 | (args 897 | (override-default-output-and-error-output args)) 898 | (proc 899 | (apply #'uiop:launch-program cmd args))) 900 | (run-hook *proc-hook* proc) 901 | proc)) 902 | 903 | ;;; From https://GitHub.com/GrammaTech/cl-utils/blob/master/shell.lisp 904 | ;;; (MIT license). 905 | (defun kill-process-group (process &key urgent) 906 | "Terminate PROCESS and all its descendants. 907 | On Unix, sends a TERM signal by default, or a KILL signal if URGENT." 908 | (uiop:close-streams process) 909 | (kill-subprocs process :urgent urgent) 910 | (if (and (os-unix-p) 911 | ;; ECL doesn't start a new process group for 912 | ;; launch-program, so this would kill the Lisp process. 913 | (not (eql :ecl (uiop:implementation-type)))) 914 | ;; Kill the entire process group (process and its children). 915 | (uiop:run-program 916 | (fmt "~a -~d -$(~a -o pgid= ~d | ~a -d ' ')" 917 | +kill+ 918 | (if urgent 9 15) 919 | +ps+ 920 | (process-info-pid process) 921 | +tr+) 922 | :ignore-error-status t) 923 | ;; If non-unix, utilize the standard terminate process 924 | ;; which should be acceptable in most cases. 925 | (uiop:terminate-process process :urgent urgent))) 926 | 927 | (-> await (process-info &key (:ignore-error-status t) (:tokens list)) 928 | fixnum) 929 | (defun await (proc &key ignore-error-status tokens) 930 | "Wait for PROC to finish." 931 | (nest 932 | (let ((out (process-info-output proc)) 933 | (err (process-info-error-output proc)))) 934 | (handler-bind ((serious-condition 935 | ;; Flush output on error. 936 | (lambda (e) (declare (ignore e)) 937 | (finish-output out) 938 | (finish-output err))))) 939 | (let ((abnormal? t))) 940 | (unwind-protect 941 | (prog1 942 | (let ((status (uiop:wait-process proc))) 943 | (cond ((zerop status) 944 | status) 945 | (ignore-error-status 946 | status) 947 | (t 948 | (cerror "IGNORE-ERROR-STATUS" 949 | 'uiop:subprocess-error 950 | :command tokens 951 | :code status 952 | :process proc) 953 | status))) 954 | (setf abnormal? nil)) 955 | (progn 956 | (uiop:close-streams proc) 957 | (when abnormal? 958 | (kill-process-group proc)))))) 959 | 960 | (defun parse-cmd-args (args &key (split t)) 961 | "Lex ARGs. 962 | The result is a list of strings, subcommand dividers, and keyword 963 | arguments." 964 | (nlet rec ((args args) 965 | (acc '())) 966 | (match args 967 | ((list) 968 | (nreverse acc)) 969 | ((list (and _ (type keyword))) 970 | (error "Dangling keyword argument to cmd.")) 971 | ((list* (and k (type subcommand-divider)) args) 972 | (rec args (cons k acc))) 973 | ((list* (and k (type keyword)) v args) 974 | (rec args (list* v k acc))) 975 | ((list* (and arg (type parseable)) args) 976 | (etypecase-of parseable arg 977 | ((or string-token substitution keyword subcommand-divider) 978 | (rec args (cons arg acc))) 979 | ;; TODO We should also handle floats, but how to print 980 | ;; exponents? And what about fractions? 981 | (integer 982 | (rec args 983 | (cons (make-string-token (princ-to-string arg)) 984 | acc))) 985 | (character 986 | (rec args 987 | (cons (make-string-token (string arg)) 988 | acc))) 989 | (string 990 | (rec args 991 | (if split 992 | (revappend (split-cmd arg) acc) 993 | (cons (make-string-token arg) 994 | acc)))) 995 | (pathname 996 | (rec args 997 | (cons (make-string-token (stringify-pathname arg)) 998 | acc))) 999 | (list 1000 | (rec args 1001 | (revappend (parse-cmd-args arg :split nil) 1002 | acc))))) 1003 | ((list* arg _) 1004 | (error "Can't use ~a as a cmd argument." arg))))) 1005 | 1006 | (defun argv+kwargs (args) 1007 | "Parse ARGS and split them into an argv and keyword arguments." 1008 | (nlet rec ((args (parse-cmd-args args)) 1009 | (argv '()) 1010 | (kwargs '())) 1011 | (ematch args 1012 | ((list) 1013 | (values (nreverse argv) 1014 | (nreverse kwargs))) 1015 | ((list* (and arg (type (or string-token substitution))) args) 1016 | (rec args 1017 | (cons arg argv) 1018 | kwargs)) 1019 | ((list* (type subcommand-divider) _) 1020 | (error "Subcommand delimiter in cmd args: ~a" args)) 1021 | ((list* (and k (type keyword)) v args) 1022 | (rec args 1023 | argv 1024 | (list* v k kwargs)))))) 1025 | 1026 | (defun wrap-with-dir (dir tokens) 1027 | "Wrap TOKENS with the necessary code to run the process in DIR. 1028 | 1029 | The OS-level current directory is per-process, not per thread. Using 1030 | `chdir' could lead to race conditions. Instead, we arrange for the new 1031 | process to change its own working directory." 1032 | (when (pathname-equal dir (getcwd)) 1033 | (return-from wrap-with-dir tokens)) 1034 | (destructuring-bind (command . args) tokens 1035 | (cond (*can-use-env-c* 1036 | ;; When there is a recent version of GNU env installed, the 1037 | ;; -C switch lets us do Bernstein chaining without spinning 1038 | ;; up a shell. 1039 | `(,+env+ "-C" ,dir ,command ,@args)) 1040 | ((not (os-windows-p)) 1041 | `(,+sh+ 1042 | "-c" 1043 | ;; Use Bernstein chaining; change to the directory in $1, 1044 | ;; shift, and exec the rest of the argument array. 1045 | "set -e; CDPATH='' cd -P \"$1\"; shift; exec \"$@\"" 1046 | ;; Terminate processing of shell options; everything 1047 | ;; after this is passed through. 1048 | "--" 1049 | ,dir 1050 | ,command 1051 | ,@args)) 1052 | ;; This looks weird, but it actually works, because the 1053 | ;; Windows API to start a process is called with a 1054 | ;; string rather than an array. We could just as well 1055 | ;; pass a string, but then we would have to do our own 1056 | ;; escaping. 1057 | (t 1058 | `("cmd" 1059 | "/c" 1060 | ;; Note that /d is required for cd to work across drives. 1061 | "cd" "/d" ,dir 1062 | ;; Ampersand is the command separator. 1063 | "&" ,command ,@args))))) 1064 | 1065 | (-> stringify-pathname ((or string pathname)) 1066 | (simple-array character (*))) 1067 | (defun stringify-pathname (arg) 1068 | (etypecase arg 1069 | (string (coerce arg '(simple-array character (*)))) 1070 | (pathname 1071 | (stringify-pathname 1072 | (lret ((string 1073 | (let ((string (native-namestring arg))) 1074 | (if (and (os-windows-p) 1075 | (featurep :ccl) 1076 | (position #\/ string)) 1077 | ;; Work around a CCL bug; issue #103 on GitHub. 1078 | (substitute #\\ #\/ string) 1079 | string)))) 1080 | (when (string^= "-" string) 1081 | ;; Should we ignore the unsafe file names if `--' or 1082 | ;; `---' is already present in the list of tokens? 1083 | (cerror "Allow the unsafe file name" 1084 | "File name ~a begins with a dash" 1085 | string))))))) 1086 | 1087 | (defun exe-string (p) 1088 | (etypecase p 1089 | ((or string pathname) 1090 | (stringify-pathname (exe p))) 1091 | (string-token 1092 | (make-string-token 1093 | (exe-string (string-token-string p)))))) 1094 | 1095 | (defun split-cmd (cmd) 1096 | (mapcar (lambda (arg) 1097 | (assure (or keyword string-token) 1098 | (or (find arg +redirection-operators+ :test #'string=) 1099 | (find arg +subcommand-dividers+ :test #'string=) 1100 | (make-string-token arg)))) 1101 | (shlex:split cmd :whitespace-split nil 1102 | :punctuation-chars t))) 1103 | --------------------------------------------------------------------------------