os.lisp (13764B)
1 ;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com> 2 ;;; 3 ;;; Permission is hereby granted, free of charge, to any person 4 ;;; obtaining a copy of this software and associated documentation 5 ;;; files (the "Software"), to deal in the Software without 6 ;;; restriction, including without limitation the rights to use, copy, 7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 ;;; of the Software, and to permit persons to whom the Software is 9 ;;; furnished to do so, subject to 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 18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 ;;; DEALINGS IN THE SOFTWARE. 22 23 (defpackage :rw.os 24 (:use :cl) 25 (:export :cmp 26 :cp 27 :make-program 28 :make-temporary-file 29 :md5sum 30 :run-command 31 :sha1sum 32 :using-flock 33 :with-program-io 34 :with-program-output 35 :with-temporary-file)) 36 37 (in-package :rw.os) 38 39 (defun make-program (input output cmd args error-plist) 40 (flet ((fail (code) 41 (unless (eq t error-plist) 42 (error (format nil "~a error ~d: ~a ~s" cmd code 43 (when error-plist 44 (or (cdr (assoc code error-plist)) "")) 45 args))))) 46 #-(or allegro ccl ecl mkcl sbcl cmucl clisp) 47 (error "RW.OS:MAKE-PROGRAM not ported") 48 #+allegro 49 (multiple-value-bind (stream b p) 50 (excl:run-shell-command (format nil "~a ~{~a~^ ~}" cmd args) 51 :input input 52 :output output 53 :error-output nil 54 :show-window nil 55 :wait nil) 56 (declare (ignore b)) 57 (flet ((status (z) 58 (if (integerp z) :exited :running))) 59 (let ((status (status (sys:reap-os-subprocess :pid p :wait nil)))) 60 (if input 61 (assert (eq :running status)) 62 (assert (member status '(:running :exited))))) 63 (let (code) 64 (lambda (msg) 65 (ecase msg 66 (:fail (fail (or (sys:reap-os-subprocess :pid p :wait nil) code))) 67 (:status-and-code 68 (let ((z (or (sys:reap-os-subprocess :pid p :wait nil) code))) 69 (values (status z) z))) 70 (:streams (values (when input stream) (when output stream))) 71 (:wait (setq code (sys:reap-os-subprocess :pid p :wait t))) 72 (:close (when stream (close stream)))))))) 73 #+ccl 74 (let ((p (ccl:run-program cmd 75 args 76 :input input 77 :output output 78 :error nil 79 :sharing :external 80 :wait nil 81 ;; TODO make bivalent 82 ;;:character-p t 83 ;;:element-type '(unsigned-byte 8) 84 ))) 85 (let ((status (ccl:external-process-status p))) 86 (if input 87 (assert (eq :running status)) 88 (assert (member status '(:running :exited))))) 89 (lambda (msg) 90 (ecase msg 91 (:fail (fail (nth-value 2 (ccl:external-process-status p)))) 92 (:status-and-code (ccl:external-process-status p)) 93 (:streams (values (ccl:external-process-input-stream p) 94 (ccl:external-process-output-stream p))) 95 (:wait (ccl::external-process-wait p)) 96 (:close (flet ((finish (x) (when x (close x)))) 97 (finish (ccl:external-process-output-stream p)) 98 (finish (ccl:external-process-input-stream p)) 99 (finish (ccl:external-process-error-stream p))))))) 100 #+ecl 101 (multiple-value-bind (io x p) 102 (ext:run-program cmd 103 args 104 :input input 105 :output output 106 :error nil 107 :wait (not (or input output))) ;; TODO why wait=nil + wait call doesnt work? 108 (declare (ignore x)) 109 (let ((status (ext:external-process-status p))) 110 (if input 111 (assert (eq :running status)) 112 (assert (member status '(:running :exited))))) 113 (lambda (msg) 114 (ecase msg 115 (:fail (fail (nth-value 2 (ext:external-process-status p)))) 116 (:status-and-code (ext:external-process-status p)) 117 (:streams (values (when input io) (when output io))) 118 (:wait (ext:external-process-wait p)) 119 (:close (when io (close io)))))) ;; TODO is this the right thing to close process? 120 #+mkcl 121 (multiple-value-bind (io p x) 122 (mkcl:run-program cmd 123 args 124 :input input 125 :output output 126 :error nil 127 :wait (not (or input output)) ;; TODO why wait=nil + wait call doesnt work? 128 :search t) 129 (let ((status (mkcl:process-status p))) 130 (if input 131 (assert (eq :running status)) 132 (assert (member status '(:running :exited))))) 133 (lambda (msg) 134 (ecase msg 135 (:fail (fail (mkcl:process-exit-code p))) 136 (:status-and-code (values (mkcl:process-status p) 137 (mkcl:process-exit-code p))) 138 (:streams (values (when input io) (when output io))) 139 (:wait (mkcl:join-process p)) 140 (:close (when io (close io)))))) 141 #+sbcl 142 (let ((p (sb-ext:run-program cmd 143 args 144 :input input 145 :output output 146 :error t 147 :wait nil 148 :search t))) 149 (let ((status (sb-ext:process-status p))) 150 (if input 151 (assert (eq :running status)) 152 (assert (member status '(:running :exited))))) 153 (lambda (msg) 154 (ecase msg 155 (:fail (fail (sb-ext:process-exit-code p))) 156 (:status-and-code (values (sb-ext:process-status p) 157 (sb-ext:process-exit-code p))) 158 (:streams (values (sb-ext:process-input p) 159 (sb-ext:process-output p))) 160 (:wait (sb-ext:process-wait p)) 161 (:close (sb-ext:process-close p))))) 162 #+cmucl 163 (let ((p (ext:run-program cmd 164 args 165 :input input 166 :output output 167 :error nil 168 :wait nil))) 169 (let ((status (ext:process-status p))) 170 (if input 171 (assert (eq :running status)) 172 (assert (member status '(:running :exited))))) 173 (lambda (msg) 174 (ecase msg 175 (:fail (fail (nth-value 2 (ext:process-status p)))) 176 (:status-and-code (ext:process-status p)) 177 (:streams (values (ext:process-input p) 178 (ext:process-output p))) 179 (:wait (ext:process-wait p)) 180 (:close (ext:process-close p))))) 181 #+clisp ;; TODO how to binary io? how to get exit code? 182 (cond 183 ((and input output) 184 (multiple-value-bind (p i o) 185 (ext:run-program cmd 186 :arguments args 187 :input input 188 :output output 189 ;;:error nil 190 :wait nil) 191 (when (and p i o) 192 (close p) 193 (lambda (msg) 194 (ecase msg 195 (:fail (fail 0)) 196 (:status-and-code (values :running 0)) 197 (:streams (values (when input i) (when output o))) 198 (:wait) 199 (:close (close i) 200 (close o))))))) 201 ((or input output) 202 (let ((p (ext:run-program cmd 203 :arguments args 204 :input input 205 :output output 206 ;;:error nil 207 :wait nil))) 208 (when p 209 (lambda (msg) 210 (ecase msg 211 (:fail (fail 0)) 212 (:status-and-code (values :running 0)) 213 (:streams (values (when input p) (when output p))) 214 (:wait) 215 (:close (close p))))))) 216 (t 217 (let (z) 218 (lambda (msg) 219 (ecase msg 220 (:fail (fail z)) 221 (:status-and-code (values :exited z)) 222 (:streams) 223 (:wait (setq z (ext:run-program cmd :arguments args :wait t))) 224 (:close)))))))) 225 226 (defun call-with-program (program fn) 227 (unwind-protect 228 (let ((z (multiple-value-bind (input output) 229 (funcall program :streams) 230 (cond 231 ((and input output) 232 (funcall fn input output)) 233 ((or input output) 234 (funcall fn (or input output))) 235 (t t))))) 236 (funcall program :wait) 237 (multiple-value-bind (status code) 238 (funcall program :status-and-code) 239 (assert (member status '(:running :exited))) 240 (if (member code '(nil 0)) 241 z 242 (funcall program :fail)))) 243 (funcall program :close))) 244 245 (defmacro with-program-io ((ivar ovar program) &body body) 246 `(call-with-program ,program (lambda (,ivar ,ovar) ,@body))) 247 248 (defmacro with-program-output ((var cmd &optional args error-plist) &body body) 249 `(call-with-program (make-program nil :stream ,cmd ,args ,error-plist) 250 (lambda (,var) ,@body))) 251 252 (defun run-command (cmd &optional args error-plist) 253 (call-with-program (make-program nil nil cmd args error-plist) nil)) 254 255 (defun %namestring (x) ;; TODO why not NAMESTRING directly usable? 256 (with-output-to-string (*standard-output*) 257 (do (c (r (rw:reader (namestring x)))) 258 ((not (setq c (rw:next r)))) 259 (when (eql #\\ c) 260 (setq c (rw:next r))) 261 (write-char c)))) 262 263 (defun %sum (command pathname) 264 (with-program-output (s command (list (%namestring pathname))) 265 (let ((x (rw:till (rw:peek-reader (rw:char-reader s)) '(#\space)))) 266 (when x 267 (coerce x 'string))))) 268 269 (defun sha1sum (pathname) 270 (%sum "sha1sum" pathname)) 271 272 ;;(sha1sum "/etc/passwd") 273 ;;(sha1sum "/etc/passwd2") 274 275 (defun md5sum (pathname) 276 (%sum "md5sum" pathname)) 277 278 ;;(md5sum "/etc/passwd") 279 ;;(md5sum "/etc/passwd2") 280 281 (defun make-temporary-file (&key directoryp template) 282 (with-program-output (s "mktemp" (append (when directoryp '("-d")) 283 (when template (list template)))) 284 (read-line s))) 285 286 ;;(make-temporary-file) 287 ;;(make-temporary-file :directoryp t) 288 ;;(make-temporary-file :template "/tmp/hi-XXXXX.log") 289 ;;(make-temporary-file :template "hi-XXXXX.log") 290 291 (defmacro with-temporary-file ((var &key directoryp template) &body body) 292 `(let ((,var (make-temporary-file :directoryp ,directoryp :template ,template))) 293 (unwind-protect (progn ,@body) 294 (delete-file ,var)))) 295 296 (defun %binary (command pathname1 pathname2 error-plist) 297 (when (and pathname1 pathname2) 298 (run-command command 299 (list (%namestring pathname1) (%namestring pathname2)) 300 error-plist))) 301 302 (defun cmp (pathname1 pathname2) 303 (%binary "cmp" pathname1 pathname2 t)) 304 305 ;;(cmp "/etc/passwd" "/etc/passwd") 306 ;;(cmp "/etc/passwd" "/etc/hosts") 307 308 (defun cp (from to) 309 (%binary "cp" from to nil)) 310 311 ;;(cp "/etc/passwd" "/tmp/a") 312 ;;(cp "/asdf" "/tmp/a") 313 314 (defun %flock (stream op) 315 #-(or sbcl ccl) 316 (error "TODO %flock not ported") 317 #+ccl 318 (#_flock (or (ccl::stream-device stream :output) 319 (ccl::stream-device stream :input)) 320 op) 321 #+sbcl 322 (let ((fd (sb-c::fd-stream-fd stream))) 323 (sb-alien:with-alien ((flock (function sb-alien:int 324 sb-alien:int 325 sb-alien:int) 326 :extern "flock")) 327 (values (sb-alien:alien-funcall flock fd op))))) 328 329 (defun %errno () 330 #-(or sbcl ccl) 331 (error "TODO %errno not ported") 332 #+ccl 333 (ccl::%get-errno) 334 #+sbcl 335 (sb-alien:get-errno)) 336 337 (defun flock (stream operation blockp) 338 #-linux 339 (error "TODO flock not ported") 340 #+linux 341 (ecase (%flock stream 342 (logior (if blockp 0 4) 343 (ecase operation 344 (:shared 1) 345 (:exclusive 2) 346 (:unlock 8)))) 347 (0 (values)) 348 (-1 (error "flock ~s ~s ~s failed with code ~s" 349 stream operation blockp (%errno))))) 350 351 (defun using-flock (pathname sharedp if-does-not-exist thunk) 352 (when (eq :create if-does-not-exist) 353 (open pathname :direction :probe :if-does-not-exist :create)) 354 (with-open-file (s pathname 355 :direction :output 356 :if-exists :overwrite) 357 (flock s (if sharedp :shared :exclusive) t) 358 (funcall thunk)))