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 |
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 -------------------------------------------------- |