5 ;;; Unix system call stuff
7 ;;; (c) 2005 Straylight/Edgeware
10 ;;;----- Licensing notice ---------------------------------------------------
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.
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.
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.
26 (defpackage #:mdw.unix
27 (:use #:common-lisp #:mdw.base #:collect)
28 (:export #:unix-error #:errno-value #:with-errno-handlers
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)
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
46 (setf ,var (system:allocate-system-memory ,lenvar))
48 (when ,var (system:deallocate-system-memory ,var ,lenvar))))))
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."))
61 (compile-time-defun errno-value (err)
62 "Returns the numeric value corresponding to an errno name."
65 (symbol (symbol-value (intern (symbol-name err) :unix)))))
67 (defmacro with-errno-handlers ((&key cond
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
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)
83 `(let (,@(when cond `(,cond))
84 ,@(when errstring `(,errstring))
86 (,formfunc (lambda () ,form)))
92 (setf ,errno (unix-error-errno ,condtmp))
94 `((setf ,cond ,condtmp)))
97 (unix:get-unix-error-msg ,errno))))
99 ,@(mapcar (lambda (cl lab)
100 `(,(fix (car cl)) (go ,lab)))
103 (return-from ,block (funcall ,formfunc)))
105 (mapc (lambda (cl lab)
107 (collect `(return-from ,block
108 (progn ,@(cdr cl)))))
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)
121 (apply #'values rc stuff))
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."
129 (macrolet ((doit (doc slots)
130 `(defstruct (stat (:predicate statp)
132 (:constructor %make-stat-boa ,slots))
136 "Structure representing all the useful information `stat' returns about a
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
143 (lambda (rc &rest results)
146 :func 'sys-stat :args (list file)
147 :error (car results)))
148 (apply #'%make-stat-boa results))
149 (unix:unix-stat file)))
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))))
157 (macrolet ((defsys (&rest names)
158 `(progn ,@(mapcar (lambda (name)
161 (defsys open close read write
162 chown fchown chmod fchmod utimes
164 gethostname gettimeofday))
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."
173 (setf ,fd (sys-open ,file ,how ,mode))
175 (when ,fd (sys-close ,fd)))))
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)
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))
192 (with-buffer (buf 16384)
194 (let ((n (sys-read in buf 16384)))
197 (sys-write out buf 0 n))))))))
199 ;;;----- That's all, folks --------------------------------------------------