chiark / gitweb /
optparse: Hack pretty-printing for CLisp.
[lisp] / unix.lisp
... / ...
CommitLineData
1;;; -*-lisp-*-
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 #:collect)
28 (:export #:unix-error #:errno-value #:with-errno-handlers
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
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))))))
49
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."))
60
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)))))
66
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
73 as 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)))))))))
111
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)
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)))
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."
126 `(syscall* ',func
127 #',func ,@args))
128
129(macrolet ((doit (doc slots)
130 `(defstruct (stat (:predicate statp)
131 (:conc-name st-)
132 (:constructor %make-stat-boa ,slots))
133 ,doc
134 ,@slots)))
135 (doit
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(defun sys-stat (file)
140 "Return information about FILE in a structure rather than as inconvenient
141 multiple values."
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
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."
170 `(let (,fd)
171 (unwind-protect
172 (progn
173 (setf ,fd (sys-open ,file ,how ,mode))
174 ,@body)
175 (when ,fd (sys-close ,fd)))))
176
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)
183 (with-unix-open (out
184 to
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))
191 (eperm nil))
192 (with-buffer (buf 16384)
193 (loop
194 (let ((n (sys-read in buf 16384)))
195 (when (zerop n)
196 (return))
197 (sys-write out buf 0 n))))))))
198
199;;;----- That's all, folks --------------------------------------------------