| 1 | ;;; -*-lisp-*0 |
| 2 | ;;; |
| 3 | ;;; $Id$ |
| 4 | ;;; |
| 5 | ;;; Unix system call stuff |
| 6 | ;;; |
| 7 | ;;; (c) 2005 Straylight/Edgeware |
| 8 | ;;; |
| 9 | |
| 10 | ;;;----- Licensing notice --------------------------------------------------- |
| 11 | ;;; |
| 12 | ;;; This program is free software; you can redistribute it and/or modify |
| 13 | ;;; it under the terms of the GNU General Public License as published by |
| 14 | ;;; the Free Software Foundation; either version 2 of the License, or |
| 15 | ;;; (at your option) any later version. |
| 16 | ;;; |
| 17 | ;;; This program is distributed in the hope that it will be useful, |
| 18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;;; GNU General Public License for more details. |
| 21 | ;;; |
| 22 | ;;; You should have received a copy of the GNU General Public License |
| 23 | ;;; along with this program; if not, write to the Free Software Foundation, |
| 24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| 25 | |
| 26 | (defpackage #:mdw.unix |
| 27 | (:use #:common-lisp #:mdw.base #:mdw.collect) |
| 28 | (:export #:unix-error #:errno-value #:with-errno-handlers |
| 29 | #:unix-try-func #:unix-try |
| 30 | #:stat |
| 31 | #:with-unix-open #:copy-file)) |
| 32 | (in-package #:mdw.unix) |
| 33 | |
| 34 | (defmacro with-buffer ((var len) &body body) |
| 35 | "Evaluate BODY with VAR bound to a pointer (a SAP, if you must know) to a |
| 36 | buffer of LEN bytes." |
| 37 | (with-gensyms lenvar |
| 38 | `(let ((,lenvar ,len) |
| 39 | (,var nil)) |
| 40 | (unwind-protect |
| 41 | (progn |
| 42 | (setf ,var (system:allocate-system-memory ,lenvar)) |
| 43 | ,@body) |
| 44 | (when ,var (system:deallocate-system-memory ,var ,lenvar)))))) |
| 45 | (define-condition unix-error (error) |
| 46 | ((func :initform 'unknown :initarg :func :reader unix-error-func) |
| 47 | (args :initform nil :initarg :args :reader unix-error-args) |
| 48 | (errno :initform 0 :initarg :errno :reader unix-error-errno)) |
| 49 | (:report (lambda (c s) |
| 50 | (format s "Error from ~A: ~A (~D)" |
| 51 | (cons (unix-error-func c) (unix-error-args c)) |
| 52 | (unix:get-unix-error-msg (unix-error-errno c)) |
| 53 | (unix-error-errno c)))) |
| 54 | (:documentation "Reports an error from a Unix system call.")) |
| 55 | (compile-time-defun errno-value (err) |
| 56 | "Returns the numeric value corresponding to an errno name." |
| 57 | (etypecase err |
| 58 | (integer err) |
| 59 | (symbol (symbol-value (intern (symbol-name err) :unix))))) |
| 60 | (defmacro with-errno-handlers ((&key cond |
| 61 | (errno (gensym)) |
| 62 | errstring) |
| 63 | form &rest clauses) |
| 64 | "Evaluate FORM but trap Unix errors according to CLAUSES. Each clause has |
| 65 | the form of a `case' clause, but may contain symbolic errno names as well as |
| 66 | numbers." |
| 67 | (flet ((fix (sw) |
| 68 | (cond ((eq sw t) 't) |
| 69 | ((atom sw) (list (errno-value sw))) |
| 70 | (t (mapcar #'errno-value sw))))) |
| 71 | (with-gensyms (block condtmp formfunc) |
| 72 | (let ((labels (mapcar (lambda (cl) |
| 73 | (declare (ignore cl)) |
| 74 | (gensym)) |
| 75 | clauses))) |
| 76 | `(let (,@(when cond `(,cond)) |
| 77 | ,@(when errstring `(,errstring)) |
| 78 | ,errno |
| 79 | (,formfunc (lambda () ,form))) |
| 80 | (block ,block |
| 81 | (tagbody |
| 82 | (handler-bind |
| 83 | ((unix-error |
| 84 | (lambda (,condtmp) |
| 85 | (setf ,errno (unix-error-errno ,condtmp)) |
| 86 | ,@(when cond |
| 87 | `((setf ,cond ,condtmp))) |
| 88 | ,@(when errstring |
| 89 | `((setf ,errstring |
| 90 | (unix:get-unix-error-msg ,errno)))) |
| 91 | (case ,errno |
| 92 | ,@(mapcar (lambda (cl lab) |
| 93 | `(,(fix (car cl)) (go ,lab))) |
| 94 | clauses |
| 95 | labels))))) |
| 96 | (return-from ,block (funcall ,formfunc))) |
| 97 | ,@(collecting () |
| 98 | (mapc (lambda (cl lab) |
| 99 | (collect lab) |
| 100 | (collect `(return-from ,block |
| 101 | (progn ,@(cdr cl))))) |
| 102 | clauses |
| 103 | labels))))))))) |
| 104 | (defun unix-try-func (name func &rest args) |
| 105 | "Call Unix system call FUNC, passing it ARGS. If it returns an error, |
| 106 | signal the unix-error condition, with NAME and ARGS." |
| 107 | (multiple-value-call (lambda (rc &rest stuff) |
| 108 | (unless rc |
| 109 | (error 'unix-error |
| 110 | :func name |
| 111 | :args args |
| 112 | :errno (car stuff))) |
| 113 | (apply #'values rc stuff)) |
| 114 | (apply func args))) |
| 115 | (defmacro unix-try (syscall &rest args) |
| 116 | "Wrapper for unix-try-func. Call Unix system-call SYSCALL (without the |
| 117 | `unix-' prefix or other stuff), passing it ARGS." |
| 118 | (let ((func (intern (format nil "UNIX-~A" (symbol-name syscall)) :unix))) |
| 119 | `(unix-try-func ',syscall #',func ,@args))) |
| 120 | (macrolet ((doit (slots) |
| 121 | `(defstruct (stat (:predicate statp) |
| 122 | (:conc-name st-) |
| 123 | (:constructor %make-stat-boa ,slots)) |
| 124 | "Structure representing all the useful information `stat' |
| 125 | returns about a file." |
| 126 | ,@slots))) |
| 127 | (doit (dev ino mode nlink uid gid rdev size |
| 128 | atime mtime ctime blksize blocks))) |
| 129 | (defun stat (file) |
| 130 | "Return information about FILE in a structure rather than as inconvenient |
| 131 | multiple values." |
| 132 | (multiple-value-call (lambda (rc &rest results) |
| 133 | (unless rc |
| 134 | (error 'unix-error :func 'stat :args (list file) |
| 135 | :error (car results))) |
| 136 | (apply #'%make-stat-boa results)) |
| 137 | (unix:unix-stat file))) |
| 138 | (defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body) |
| 139 | "Evaluate BODY with FD bound to a file descriptor obtained from a Unix |
| 140 | `open' syscall with arguments FILE, HOW and MODE. Close the file descriptor |
| 141 | when BODY is done." |
| 142 | `(let (,fd) |
| 143 | (unwind-protect |
| 144 | (progn |
| 145 | (setf ,fd (unix-try open ,file ,how ,mode)) |
| 146 | ,@body) |
| 147 | (when ,fd (unix-try close ,fd))))) |
| 148 | (defun copy-file (from to &optional (how 0)) |
| 149 | "Make a copy of the file FROM called TO. The copy has the same permissions |
| 150 | and timestamps (except for ctime) and attempts to have the same owner and |
| 151 | group as the original." |
| 152 | (let ((st (stat from))) |
| 153 | (with-unix-open (in from unix:o_rdonly) |
| 154 | (with-unix-open (out |
| 155 | to |
| 156 | (logior unix:o_wronly unix:o_creat how) |
| 157 | (logand (st-mode st) #o777)) |
| 158 | (unix-try fchmod out (st-mode st)) |
| 159 | (unix-try utimes to (st-atime st) 0 (st-mtime st) 0) |
| 160 | (with-errno-handlers () |
| 161 | (unix-try fchown out (st-uid st) (st-gid st)) |
| 162 | (eperm nil)) |
| 163 | (with-buffer (buf 16384) |
| 164 | (loop |
| 165 | (let ((n (unix-try read in buf 16384))) |
| 166 | (when (zerop n) |
| 167 | (return)) |
| 168 | (unix-try write out buf 0 n)))))))) |
| 169 | |
| 170 | ;;;----- That's all, folks -------------------------------------------------- |