3 ;;; Unix system call stuff
5 ;;; (c) 2005 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
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.
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.
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.
24 (defpackage #:mdw.unix
25 (:use #:common-lisp #:mdw.base #:collect))
26 (in-package #:mdw.unix)
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
36 (setf ,var (system:allocate-system-memory ,lenvar))
38 (when ,var (system:deallocate-system-memory ,var ,lenvar))))))
40 (export '(unix-error unix-error-func unix-error-args unix-error-errno))
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."))
53 (compile-time-defun errno-value (err)
54 "Returns the numeric value corresponding to an errno name."
57 (symbol (symbol-value (intern (symbol-name err) :unix)))))
59 (export 'with-errno-handlers)
60 (defmacro with-errno-handlers ((&key cond
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
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)
76 `(let (,@(when cond `(,cond))
77 ,@(when errstring `(,errstring))
79 (,formfunc (lambda () ,form)))
85 (setf ,errno (unix-error-errno ,condtmp))
87 `((setf ,cond ,condtmp)))
90 (unix:get-unix-error-msg ,errno))))
92 ,@(mapcar (lambda (cl lab)
93 `(,(fix (car cl)) (go ,lab)))
96 (return-from ,block (funcall ,formfunc)))
98 (mapc (lambda (cl lab)
100 (collect `(return-from ,block
101 (progn ,@(cdr cl)))))
106 (defun syscall* (name func &rest args)
107 "Call Unix system call FUNC, passing it ARGS. If it returns an error,
108 signal the unix-error condition, with NAME and ARGS."
109 (multiple-value-call (lambda (rc &rest stuff)
115 (apply #'values rc stuff))
119 (defmacro syscall (func &rest args)
120 "Call Unix system call FUNC, passing it ARGS. If it returns an error,
121 signal the unix-error condition, with FUNC and ARGS."
125 (export '(stat statp))
126 (macrolet ((doit (doc slots)
128 (export ',(mapcar (lambda (slot) (symbolicate 'st- slot))
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)))
141 (defun sys-stat (file)
142 "Return information about FILE in a structure rather than as inconvenient
145 (lambda (rc &rest results)
148 :func 'sys-stat :args (list file)
149 :error (car results)))
150 (apply #'%make-stat-boa results))
151 (unix:unix-stat file)))
153 (defmacro defsyscall (name)
154 (let ((sysname (symbolicate 'sys- name))
155 (unixname (let ((*package* (find-package :unix)))
156 (symbolicate 'unix- name))))
159 (defun ,sysname (&rest args)
160 (apply #'syscall* ',sysname #',unixname args)))))
162 (macrolet ((defsys (&rest names)
163 `(progn ,@(mapcar (lambda (name)
166 (defsys open close read write
167 chown fchown chmod fchmod utimes
169 gethostname gettimeofday))
171 (export 'with-unix-open)
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
174 `open' syscall with arguments FILE, HOW and MODE. Close the file
175 descriptor when BODY is done."
179 (setf ,fd (sys-open ,file ,how ,mode))
181 (when ,fd (sys-close ,fd)))))
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
186 and timestamps (except for ctime) and attempts to have the same owner and
187 group as the original."
188 (let ((st (sys-stat from)))
189 (with-unix-open (in from unix:O_RDONLY)
192 (logior unix:O_WRONLY unix:O_CREAT how)
193 (logand (st-mode st) #o777))
194 (sys-fchmod out (st-mode st))
195 (sys-utimes to (st-atime st) 0 (st-mtime st) 0)
196 (with-errno-handlers ()
197 (sys-fchown out (st-uid st) (st-gid st))
199 (with-buffer (buf 16384)
201 (let ((n (sys-read in buf 16384)))
204 (sys-write out buf 0 n))))))))
206 ;;;----- That's all, folks --------------------------------------------------