| 1 | ;;; -*-lisp-*- |
| 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 #:collect) |
| 28 | (:export #:unix-error #:errno-value #:with-errno-handlers |
| 29 | #:syscall #:syscall* |
| 30 | #:stat #:sys-stat |
| 31 | #:sys-open #:sys-close #:sys-read #:sys-write |
| 32 | #:sys-chown #:sys-fchown #:sys-chmod #:sys-fchmod |
| 33 | #:sys-utimes #:sys-unlink #:sys-rename |
| 34 | #:sys-gettimeofday #:sys-gethostname |
| 35 | #:with-unix-open #:copy-file)) |
| 36 | (in-package #:mdw.unix) |
| 37 | |
| 38 | (defmacro with-buffer ((var len) &body body) |
| 39 | "Evaluate BODY with VAR bound to a pointer (a SAP, if you must know) to a |
| 40 | buffer of LEN bytes." |
| 41 | (with-gensyms lenvar |
| 42 | `(let ((,lenvar ,len) |
| 43 | (,var nil)) |
| 44 | (unwind-protect |
| 45 | (progn |
| 46 | (setf ,var (system:allocate-system-memory ,lenvar)) |
| 47 | ,@body) |
| 48 | (when ,var (system:deallocate-system-memory ,var ,lenvar)))))) |
| 49 | |
| 50 | (define-condition unix-error (error) |
| 51 | ((func :initform 'unknown :initarg :func :reader unix-error-func) |
| 52 | (args :initform nil :initarg :args :reader unix-error-args) |
| 53 | (errno :initform 0 :initarg :errno :reader unix-error-errno)) |
| 54 | (:report (lambda (c s) |
| 55 | (format s "Error from ~A: ~A (~D)" |
| 56 | (cons (unix-error-func c) (unix-error-args c)) |
| 57 | (unix:get-unix-error-msg (unix-error-errno c)) |
| 58 | (unix-error-errno c)))) |
| 59 | (:documentation "Reports an error from a Unix system call.")) |
| 60 | |
| 61 | (compile-time-defun errno-value (err) |
| 62 | "Returns the numeric value corresponding to an errno name." |
| 63 | (etypecase err |
| 64 | (integer err) |
| 65 | (symbol (symbol-value (intern (symbol-name err) :unix))))) |
| 66 | |
| 67 | (defmacro with-errno-handlers ((&key cond |
| 68 | (errno (gensym)) |
| 69 | errstring) |
| 70 | form &rest clauses) |
| 71 | "Evaluate FORM but trap Unix errors according to CLAUSES. Each clause has |
| 72 | the form of a `case' clause, but may contain symbolic errno names as well |
| 73 | as numbers." |
| 74 | (flet ((fix (sw) |
| 75 | (cond ((eq sw t) 't) |
| 76 | ((atom sw) (list (errno-value sw))) |
| 77 | (t (mapcar #'errno-value sw))))) |
| 78 | (with-gensyms (block condtmp formfunc) |
| 79 | (let ((labels (mapcar (lambda (cl) |
| 80 | (declare (ignore cl)) |
| 81 | (gensym)) |
| 82 | clauses))) |
| 83 | `(let (,@(when cond `(,cond)) |
| 84 | ,@(when errstring `(,errstring)) |
| 85 | ,errno |
| 86 | (,formfunc (lambda () ,form))) |
| 87 | (block ,block |
| 88 | (tagbody |
| 89 | (handler-bind |
| 90 | ((unix-error |
| 91 | (lambda (,condtmp) |
| 92 | (setf ,errno (unix-error-errno ,condtmp)) |
| 93 | ,@(when cond |
| 94 | `((setf ,cond ,condtmp))) |
| 95 | ,@(when errstring |
| 96 | `((setf ,errstring |
| 97 | (unix:get-unix-error-msg ,errno)))) |
| 98 | (case ,errno |
| 99 | ,@(mapcar (lambda (cl lab) |
| 100 | `(,(fix (car cl)) (go ,lab))) |
| 101 | clauses |
| 102 | labels))))) |
| 103 | (return-from ,block (funcall ,formfunc))) |
| 104 | ,@(collecting () |
| 105 | (mapc (lambda (cl lab) |
| 106 | (collect lab) |
| 107 | (collect `(return-from ,block |
| 108 | (progn ,@(cdr cl))))) |
| 109 | clauses |
| 110 | labels))))))))) |
| 111 | |
| 112 | (defun syscall* (name func &rest args) |
| 113 | "Call Unix system call FUNC, passing it ARGS. If it returns an error, |
| 114 | signal the unix-error condition, with NAME and ARGS." |
| 115 | (multiple-value-call (lambda (rc &rest stuff) |
| 116 | (unless rc |
| 117 | (error 'unix-error |
| 118 | :func name |
| 119 | :args args |
| 120 | :errno (car stuff))) |
| 121 | (apply #'values rc stuff)) |
| 122 | (apply func args))) |
| 123 | (defmacro syscall (func &rest args) |
| 124 | "Call Unix system call FUNC, passing it ARGS. If it returns an error, |
| 125 | signal the unix-error condition, with FUNC and ARGS." |
| 126 | `(syscall* ',func |
| 127 | #',func ,@args)) |
| 128 | |
| 129 | (macrolet ((doit (doc slots) |
| 130 | `(defstruct (stat (:predicate statp) |
| 131 | (:conc-name st-) |
| 132 | (:constructor %make-stat-boa ,slots)) |
| 133 | ,doc |
| 134 | ,@slots))) |
| 135 | (doit |
| 136 | "Structure representing all the useful information `stat' returns about a |
| 137 | file." |
| 138 | (dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks))) |
| 139 | (defun sys-stat (file) |
| 140 | "Return information about FILE in a structure rather than as inconvenient |
| 141 | multiple values." |
| 142 | (multiple-value-call |
| 143 | (lambda (rc &rest results) |
| 144 | (unless rc |
| 145 | (error 'unix-error |
| 146 | :func 'sys-stat :args (list file) |
| 147 | :error (car results))) |
| 148 | (apply #'%make-stat-boa results)) |
| 149 | (unix:unix-stat file))) |
| 150 | |
| 151 | (defmacro defsyscall (name) |
| 152 | (let ((sysname (intern (format nil "SYS-~:@(~A~)" name))) |
| 153 | (unixname (intern (format nil "UNIX-~:@(~A~)" name) :unix))) |
| 154 | `(defun ,sysname (&rest args) |
| 155 | (apply #'syscall* ',sysname #',unixname args)))) |
| 156 | |
| 157 | (macrolet ((defsys (&rest names) |
| 158 | `(progn ,@(mapcar (lambda (name) |
| 159 | `(defsyscall ,name)) |
| 160 | names)))) |
| 161 | (defsys open close read write |
| 162 | chown fchown chmod fchmod utimes |
| 163 | unlink rename |
| 164 | gethostname gettimeofday)) |
| 165 | |
| 166 | (defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body) |
| 167 | "Evaluate BODY with FD bound to a file descriptor obtained from a Unix |
| 168 | `open' syscall with arguments FILE, HOW and MODE. Close the file |
| 169 | descriptor when BODY is done." |
| 170 | `(let (,fd) |
| 171 | (unwind-protect |
| 172 | (progn |
| 173 | (setf ,fd (sys-open ,file ,how ,mode)) |
| 174 | ,@body) |
| 175 | (when ,fd (sys-close ,fd))))) |
| 176 | |
| 177 | (defun copy-file (from to &optional (how 0)) |
| 178 | "Make a copy of the file FROM called TO. The copy has the same permissions |
| 179 | and timestamps (except for ctime) and attempts to have the same owner and |
| 180 | group as the original." |
| 181 | (let ((st (sys-stat from))) |
| 182 | (with-unix-open (in from unix:O_RDONLY) |
| 183 | (with-unix-open (out |
| 184 | to |
| 185 | (logior unix:O_WRONLY unix:O_CREAT how) |
| 186 | (logand (st-mode st) #o777)) |
| 187 | (sys-fchmod out (st-mode st)) |
| 188 | (sys-utimes to (st-atime st) 0 (st-mtime st) 0) |
| 189 | (with-errno-handlers () |
| 190 | (sys-fchown out (st-uid st) (st-gid st)) |
| 191 | (eperm nil)) |
| 192 | (with-buffer (buf 16384) |
| 193 | (loop |
| 194 | (let ((n (sys-read in buf 16384))) |
| 195 | (when (zerop n) |
| 196 | (return)) |
| 197 | (sys-write out buf 0 n)))))))) |
| 198 | |
| 199 | ;;;----- That's all, folks -------------------------------------------------- |