Commit | Line | Data |
---|---|---|
80c777c5 | 1 | ;;; -*-lisp-*- |
861345b4 | 2 | ;;; |
861345b4 | 3 | ;;; Unix system call stuff |
4 | ;;; | |
5 | ;;; (c) 2005 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This program is free software; you can redistribute it and/or modify | |
11 | ;;; it under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 2 of the License, or | |
13 | ;;; (at your option) any later version. | |
b2c12b4e | 14 | ;;; |
861345b4 | 15 | ;;; This program is distributed in the hope that it will be useful, |
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
b2c12b4e | 19 | ;;; |
861345b4 | 20 | ;;; You should have received a copy of the GNU General Public License |
21 | ;;; along with this program; if not, write to the Free Software Foundation, | |
22 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
23 | ||
24 | (defpackage #:mdw.unix | |
77f935da | 25 | (:use #:common-lisp #:mdw.base #:collect)) |
861345b4 | 26 | (in-package #:mdw.unix) |
27 | ||
28 | (defmacro with-buffer ((var len) &body body) | |
29 | "Evaluate BODY with VAR bound to a pointer (a SAP, if you must know) to a | |
0ff9df03 | 30 | buffer of LEN bytes." |
861345b4 | 31 | (with-gensyms lenvar |
32 | `(let ((,lenvar ,len) | |
33 | (,var nil)) | |
34 | (unwind-protect | |
b2c12b4e | 35 | (progn |
861345b4 | 36 | (setf ,var (system:allocate-system-memory ,lenvar)) |
37 | ,@body) | |
38 | (when ,var (system:deallocate-system-memory ,var ,lenvar)))))) | |
ad8995ca | 39 | |
77f935da | 40 | (export '(unix-error unix-error-func unix-error-args unix-error-errno)) |
861345b4 | 41 | (define-condition unix-error (error) |
42 | ((func :initform 'unknown :initarg :func :reader unix-error-func) | |
43 | (args :initform nil :initarg :args :reader unix-error-args) | |
44 | (errno :initform 0 :initarg :errno :reader unix-error-errno)) | |
45 | (:report (lambda (c s) | |
46 | (format s "Error from ~A: ~A (~D)" | |
47 | (cons (unix-error-func c) (unix-error-args c)) | |
48 | (unix:get-unix-error-msg (unix-error-errno c)) | |
49 | (unix-error-errno c)))) | |
50 | (:documentation "Reports an error from a Unix system call.")) | |
ad8995ca | 51 | |
77f935da | 52 | (export 'errno-value) |
861345b4 | 53 | (compile-time-defun errno-value (err) |
77f935da MW |
54 | "Returns the numeric value corresponding to an errno name." |
55 | (etypecase err | |
56 | (integer err) | |
57 | (symbol (symbol-value (intern (symbol-name err) :unix))))) | |
ad8995ca | 58 | |
77f935da | 59 | (export 'with-errno-handlers) |
861345b4 | 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 | |
0ff9df03 MW |
65 | the form of a `case' clause, but may contain symbolic errno names as well |
66 | as numbers." | |
861345b4 | 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))))))))) | |
ad8995ca | 104 | |
77f935da | 105 | (export 'syscall*) |
ad8995ca | 106 | (defun syscall* (name func &rest args) |
861345b4 | 107 | "Call Unix system call FUNC, passing it ARGS. If it returns an error, |
0ff9df03 | 108 | signal the unix-error condition, with NAME and ARGS." |
861345b4 | 109 | (multiple-value-call (lambda (rc &rest stuff) |
110 | (unless rc | |
111 | (error 'unix-error | |
112 | :func name | |
113 | :args args | |
114 | :errno (car stuff))) | |
115 | (apply #'values rc stuff)) | |
116 | (apply func args))) | |
77f935da MW |
117 | |
118 | (export 'syscall) | |
ad8995ca MW |
119 | (defmacro syscall (func &rest args) |
120 | "Call Unix system call FUNC, passing it ARGS. If it returns an error, | |
0ff9df03 MW |
121 | signal the unix-error condition, with FUNC and ARGS." |
122 | `(syscall* ',func | |
123 | #',func ,@args)) | |
ad8995ca | 124 | |
77f935da | 125 | (export '(stat statp)) |
ad8995ca | 126 | (macrolet ((doit (doc slots) |
77f935da MW |
127 | `(progn |
128 | (export ',(mapcar (lambda (slot) (symbolicate 'st- slot)) | |
129 | slots)) | |
130 | (defstruct (stat (:predicate statp) | |
131 | (:conc-name st-) | |
132 | (:constructor %make-stat-boa ,slots)) | |
133 | ,doc | |
134 | ,@slots)))) | |
ad8995ca | 135 | (doit |
77f935da MW |
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 | ||
140 | (export 'sys-stat) | |
ad8995ca | 141 | (defun sys-stat (file) |
861345b4 | 142 | "Return information about FILE in a structure rather than as inconvenient |
0ff9df03 | 143 | multiple values." |
ad8995ca MW |
144 | (multiple-value-call |
145 | (lambda (rc &rest results) | |
146 | (unless rc | |
147 | (error 'unix-error | |
148 | :func 'sys-stat :args (list file) | |
149 | :error (car results))) | |
150 | (apply #'%make-stat-boa results)) | |
151 | (unix:unix-stat file))) | |
152 | ||
153 | (defmacro defsyscall (name) | |
77f935da MW |
154 | (let ((sysname (symbolicate 'sys- name)) |
155 | (unixname (let ((*package* (find-package :unix))) | |
156 | (symbolicate 'unix- name)))) | |
157 | `(progn | |
158 | (export ',sysname) | |
159 | (defun ,sysname (&rest args) | |
160 | (apply #'syscall* ',sysname #',unixname args))))) | |
ad8995ca MW |
161 | |
162 | (macrolet ((defsys (&rest names) | |
b2c12b4e | 163 | `(progn ,@(mapcar (lambda (name) |
ad8995ca MW |
164 | `(defsyscall ,name)) |
165 | names)))) | |
166 | (defsys open close read write | |
167 | chown fchown chmod fchmod utimes | |
168 | unlink rename | |
169 | gethostname gettimeofday)) | |
170 | ||
77f935da | 171 | (export 'with-unix-open) |
861345b4 | 172 | (defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body) |
173 | "Evaluate BODY with FD bound to a file descriptor obtained from a Unix | |
0ff9df03 MW |
174 | `open' syscall with arguments FILE, HOW and MODE. Close the file |
175 | descriptor when BODY is done." | |
861345b4 | 176 | `(let (,fd) |
177 | (unwind-protect | |
178 | (progn | |
ad8995ca | 179 | (setf ,fd (sys-open ,file ,how ,mode)) |
861345b4 | 180 | ,@body) |
ad8995ca MW |
181 | (when ,fd (sys-close ,fd))))) |
182 | ||
77f935da | 183 | (export 'copy-file) |
861345b4 | 184 | (defun copy-file (from to &optional (how 0)) |
185 | "Make a copy of the file FROM called TO. The copy has the same permissions | |
0ff9df03 MW |
186 | and timestamps (except for ctime) and attempts to have the same owner and |
187 | group as the original." | |
ad8995ca MW |
188 | (let ((st (sys-stat from))) |
189 | (with-unix-open (in from unix:O_RDONLY) | |
861345b4 | 190 | (with-unix-open (out |
191 | to | |
ad8995ca | 192 | (logior unix:O_WRONLY unix:O_CREAT how) |
861345b4 | 193 | (logand (st-mode st) #o777)) |
4da88bb9 | 194 | (sys-fchmod out (st-mode st)) |
ad8995ca | 195 | (sys-utimes to (st-atime st) 0 (st-mtime st) 0) |
861345b4 | 196 | (with-errno-handlers () |
ad8995ca | 197 | (sys-fchown out (st-uid st) (st-gid st)) |
861345b4 | 198 | (eperm nil)) |
199 | (with-buffer (buf 16384) | |
200 | (loop | |
ad8995ca | 201 | (let ((n (sys-read in buf 16384))) |
861345b4 | 202 | (when (zerop n) |
203 | (return)) | |
ad8995ca | 204 | (sys-write out buf 0 n)))))))) |
861345b4 | 205 | |
206 | ;;;----- That's all, folks -------------------------------------------------- |