Commit | Line | Data |
---|---|---|
80c777c5 | 1 | ;;; -*-lisp-*- |
861345b4 | 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 | |
bf0a8c39 | 27 | (:use #:common-lisp #:mdw.base #:collect) |
861345b4 | 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 | |
0ff9df03 | 40 | buffer of LEN bytes." |
861345b4 | 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 | |
0ff9df03 MW |
72 | the form of a `case' clause, but may contain symbolic errno names as well |
73 | as numbers." | |
861345b4 | 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, |
0ff9df03 | 114 | signal the unix-error condition, with NAME and ARGS." |
861345b4 | 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, | |
0ff9df03 MW |
125 | signal the unix-error condition, with FUNC and ARGS." |
126 | `(syscall* ',func | |
127 | #',func ,@args)) | |
ad8995ca MW |
128 | |
129 | (macrolet ((doit (doc slots) | |
861345b4 | 130 | `(defstruct (stat (:predicate statp) |
131 | (:conc-name st-) | |
132 | (:constructor %make-stat-boa ,slots)) | |
ad8995ca MW |
133 | ,doc |
134 | ,@slots))) | |
135 | (doit | |
0ff9df03 MW |
136 | "Structure representing all the useful information `stat' returns about a |
137 | file." | |
ad8995ca MW |
138 | (dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks))) |
139 | (defun sys-stat (file) | |
861345b4 | 140 | "Return information about FILE in a structure rather than as inconvenient |
0ff9df03 | 141 | multiple values." |
ad8995ca MW |
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 | ||
861345b4 | 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 | |
0ff9df03 MW |
168 | `open' syscall with arguments FILE, HOW and MODE. Close the file |
169 | descriptor when BODY is done." | |
861345b4 | 170 | `(let (,fd) |
171 | (unwind-protect | |
172 | (progn | |
ad8995ca | 173 | (setf ,fd (sys-open ,file ,how ,mode)) |
861345b4 | 174 | ,@body) |
ad8995ca MW |
175 | (when ,fd (sys-close ,fd))))) |
176 | ||
861345b4 | 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 | |
0ff9df03 MW |
179 | and timestamps (except for ctime) and attempts to have the same owner and |
180 | group as the original." | |
ad8995ca MW |
181 | (let ((st (sys-stat from))) |
182 | (with-unix-open (in from unix:O_RDONLY) | |
861345b4 | 183 | (with-unix-open (out |
184 | to | |
ad8995ca | 185 | (logior unix:O_WRONLY unix:O_CREAT how) |
861345b4 | 186 | (logand (st-mode st) #o777)) |
ad8995ca MW |
187 | (sys-fchmod out (st-mode st)) |
188 | (sys-utimes to (st-atime st) 0 (st-mtime st) 0) | |
861345b4 | 189 | (with-errno-handlers () |
ad8995ca | 190 | (sys-fchown out (st-uid st) (st-gid st)) |
861345b4 | 191 | (eperm nil)) |
192 | (with-buffer (buf 16384) | |
193 | (loop | |
ad8995ca | 194 | (let ((n (sys-read in buf 16384))) |
861345b4 | 195 | (when (zerop n) |
196 | (return)) | |
ad8995ca | 197 | (sys-write out buf 0 n)))))))) |
861345b4 | 198 | |
199 | ;;;----- That's all, folks -------------------------------------------------- |