Commit | Line | Data |
---|---|---|
861345b4 | 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 | |
ad8995ca MW |
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 | |
861345b4 | 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)))))) | |
ad8995ca | 49 | |
861345b4 | 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.")) | |
ad8995ca | 60 | |
861345b4 | 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))))) | |
ad8995ca | 66 | |
861345b4 | 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 as | |
73 | 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))))))))) | |
ad8995ca MW |
111 | |
112 | (defun syscall* (name func &rest args) | |
861345b4 | 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))) | |
ad8995ca MW |
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." | |
287fd2e6 | 126 | `(syscall* ',func #',func ,@args)) |
ad8995ca MW |
127 | |
128 | (macrolet ((doit (doc slots) | |
861345b4 | 129 | `(defstruct (stat (:predicate statp) |
130 | (:conc-name st-) | |
131 | (:constructor %make-stat-boa ,slots)) | |
ad8995ca MW |
132 | ,doc |
133 | ,@slots))) | |
134 | (doit | |
135 | "Structure representing all the useful information `stat' returns about | |
136 | a file." | |
137 | (dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks))) | |
138 | (defun sys-stat (file) | |
861345b4 | 139 | "Return information about FILE in a structure rather than as inconvenient |
140 | multiple values." | |
ad8995ca MW |
141 | (multiple-value-call |
142 | (lambda (rc &rest results) | |
143 | (unless rc | |
144 | (error 'unix-error | |
145 | :func 'sys-stat :args (list file) | |
146 | :error (car results))) | |
147 | (apply #'%make-stat-boa results)) | |
148 | (unix:unix-stat file))) | |
149 | ||
150 | (defmacro defsyscall (name) | |
151 | (let ((sysname (intern (format nil "SYS-~:@(~A~)" name))) | |
152 | (unixname (intern (format nil "UNIX-~:@(~A~)" name) :unix))) | |
153 | `(defun ,sysname (&rest args) | |
154 | (apply #'syscall* ',sysname #',unixname args)))) | |
155 | ||
156 | (macrolet ((defsys (&rest names) | |
157 | `(progn ,@(mapcar (lambda (name) | |
158 | `(defsyscall ,name)) | |
159 | names)))) | |
160 | (defsys open close read write | |
161 | chown fchown chmod fchmod utimes | |
162 | unlink rename | |
163 | gethostname gettimeofday)) | |
164 | ||
861345b4 | 165 | (defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body) |
166 | "Evaluate BODY with FD bound to a file descriptor obtained from a Unix | |
167 | `open' syscall with arguments FILE, HOW and MODE. Close the file descriptor | |
168 | when BODY is done." | |
169 | `(let (,fd) | |
170 | (unwind-protect | |
171 | (progn | |
ad8995ca | 172 | (setf ,fd (sys-open ,file ,how ,mode)) |
861345b4 | 173 | ,@body) |
ad8995ca MW |
174 | (when ,fd (sys-close ,fd))))) |
175 | ||
861345b4 | 176 | (defun copy-file (from to &optional (how 0)) |
177 | "Make a copy of the file FROM called TO. The copy has the same permissions | |
178 | and timestamps (except for ctime) and attempts to have the same owner and | |
179 | group as the original." | |
ad8995ca MW |
180 | (let ((st (sys-stat from))) |
181 | (with-unix-open (in from unix:O_RDONLY) | |
861345b4 | 182 | (with-unix-open (out |
183 | to | |
ad8995ca | 184 | (logior unix:O_WRONLY unix:O_CREAT how) |
861345b4 | 185 | (logand (st-mode st) #o777)) |
ad8995ca MW |
186 | (sys-fchmod out (st-mode st)) |
187 | (sys-utimes to (st-atime st) 0 (st-mtime st) 0) | |
861345b4 | 188 | (with-errno-handlers () |
ad8995ca | 189 | (sys-fchown out (st-uid st) (st-gid st)) |
861345b4 | 190 | (eperm nil)) |
191 | (with-buffer (buf 16384) | |
192 | (loop | |
ad8995ca | 193 | (let ((n (sys-read in buf 16384))) |
861345b4 | 194 | (when (zerop n) |
195 | (return)) | |
ad8995ca | 196 | (sys-write out buf 0 n)))))))) |
861345b4 | 197 | |
198 | ;;;----- That's all, folks -------------------------------------------------- |