-;;; -*-lisp-*0
-;;;
-;;; $Id$
+;;; -*-lisp-*-
;;;
;;; Unix system call stuff
;;;
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
-;;;
+;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
-;;;
+;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(defpackage #:mdw.unix
- (:use #:common-lisp #:mdw.base #:mdw.collect)
- (:export #:unix-error #:errno-value #:with-errno-handlers
- #:unix-try-func #:unix-try
- #:stat
- #:with-unix-open #:copy-file))
+ (:use #:common-lisp #:mdw.base #:collect))
(in-package #:mdw.unix)
(defmacro with-buffer ((var len) &body body)
"Evaluate BODY with VAR bound to a pointer (a SAP, if you must know) to a
-buffer of LEN bytes."
+ buffer of LEN bytes."
(with-gensyms lenvar
`(let ((,lenvar ,len)
(,var nil))
(unwind-protect
- (progn
+ (progn
(setf ,var (system:allocate-system-memory ,lenvar))
,@body)
(when ,var (system:deallocate-system-memory ,var ,lenvar))))))
+
+(export '(unix-error unix-error-func unix-error-args unix-error-errno))
(define-condition unix-error (error)
((func :initform 'unknown :initarg :func :reader unix-error-func)
(args :initform nil :initarg :args :reader unix-error-args)
(unix:get-unix-error-msg (unix-error-errno c))
(unix-error-errno c))))
(:documentation "Reports an error from a Unix system call."))
+
+(export 'errno-value)
(compile-time-defun errno-value (err)
- "Returns the numeric value corresponding to an errno name."
- (etypecase err
- (integer err)
- (symbol (symbol-value (intern (symbol-name err) :unix)))))
+ "Returns the numeric value corresponding to an errno name."
+ (etypecase err
+ (integer err)
+ (symbol (symbol-value (intern (symbol-name err) :unix)))))
+
+(export 'with-errno-handlers)
(defmacro with-errno-handlers ((&key cond
(errno (gensym))
errstring)
form &rest clauses)
"Evaluate FORM but trap Unix errors according to CLAUSES. Each clause has
-the form of a `case' clause, but may contain symbolic errno names as well as
-numbers."
+ the form of a `case' clause, but may contain symbolic errno names as well
+ as numbers."
(flet ((fix (sw)
(cond ((eq sw t) 't)
((atom sw) (list (errno-value sw)))
(progn ,@(cdr cl)))))
clauses
labels)))))))))
-(defun unix-try-func (name func &rest args)
+
+(export 'syscall*)
+(defun syscall* (name func &rest args)
"Call Unix system call FUNC, passing it ARGS. If it returns an error,
-signal the unix-error condition, with NAME and ARGS."
+ signal the unix-error condition, with NAME and ARGS."
(multiple-value-call (lambda (rc &rest stuff)
(unless rc
(error 'unix-error
:errno (car stuff)))
(apply #'values rc stuff))
(apply func args)))
-(defmacro unix-try (syscall &rest args)
- "Wrapper for unix-try-func. Call Unix system-call SYSCALL (without the
-`unix-' prefix or other stuff), passing it ARGS."
- (let ((func (intern (format nil "UNIX-~A" (symbol-name syscall)) :unix)))
- `(unix-try-func ',syscall #',func ,@args)))
-(macrolet ((doit (slots)
- `(defstruct (stat (:predicate statp)
- (:conc-name st-)
- (:constructor %make-stat-boa ,slots))
- "Structure representing all the useful information `stat'
-returns about a file."
- ,@slots)))
- (doit (dev ino mode nlink uid gid rdev size
- atime mtime ctime blksize blocks)))
-(defun stat (file)
+
+(export 'syscall)
+(defmacro syscall (func &rest args)
+ "Call Unix system call FUNC, passing it ARGS. If it returns an error,
+ signal the unix-error condition, with FUNC and ARGS."
+ `(syscall* ',func
+ #',func ,@args))
+
+(export '(stat statp))
+(macrolet ((doit (doc slots)
+ `(progn
+ (export ',(mapcar (lambda (slot) (symbolicate 'st- slot))
+ slots))
+ (defstruct (stat (:predicate statp)
+ (:conc-name st-)
+ (:constructor %make-stat-boa ,slots))
+ ,doc
+ ,@slots))))
+ (doit
+ "Structure representing all the useful information `stat' returns about a
+ file."
+ (dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks)))
+
+(export 'sys-stat)
+(defun sys-stat (file)
"Return information about FILE in a structure rather than as inconvenient
-multiple values."
- (multiple-value-call (lambda (rc &rest results)
- (unless rc
- (error 'unix-error :func 'stat :args (list file)
- :error (car results)))
- (apply #'%make-stat-boa results))
- (unix:unix-stat file)))
+ multiple values."
+ (multiple-value-call
+ (lambda (rc &rest results)
+ (unless rc
+ (error 'unix-error
+ :func 'sys-stat :args (list file)
+ :error (car results)))
+ (apply #'%make-stat-boa results))
+ (unix:unix-stat file)))
+
+(defmacro defsyscall (name)
+ (let ((sysname (symbolicate 'sys- name))
+ (unixname (let ((*package* (find-package :unix)))
+ (symbolicate 'unix- name))))
+ `(progn
+ (export ',sysname)
+ (defun ,sysname (&rest args)
+ (apply #'syscall* ',sysname #',unixname args)))))
+
+(macrolet ((defsys (&rest names)
+ `(progn ,@(mapcar (lambda (name)
+ `(defsyscall ,name))
+ names))))
+ (defsys open close read write
+ chown fchown chmod fchmod utimes
+ unlink rename
+ gethostname gettimeofday))
+
+(export 'with-unix-open)
(defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body)
"Evaluate BODY with FD bound to a file descriptor obtained from a Unix
-`open' syscall with arguments FILE, HOW and MODE. Close the file descriptor
-when BODY is done."
+ `open' syscall with arguments FILE, HOW and MODE. Close the file
+ descriptor when BODY is done."
`(let (,fd)
(unwind-protect
(progn
- (setf ,fd (unix-try open ,file ,how ,mode))
+ (setf ,fd (sys-open ,file ,how ,mode))
,@body)
- (when ,fd (unix-try close ,fd)))))
+ (when ,fd (sys-close ,fd)))))
+
+(export 'copy-file)
(defun copy-file (from to &optional (how 0))
"Make a copy of the file FROM called TO. The copy has the same permissions
-and timestamps (except for ctime) and attempts to have the same owner and
-group as the original."
- (let ((st (stat from)))
- (with-unix-open (in from unix:o_rdonly)
+ and timestamps (except for ctime) and attempts to have the same owner and
+ group as the original."
+ (let ((st (sys-stat from)))
+ (with-unix-open (in from unix:O_RDONLY)
(with-unix-open (out
to
- (logior unix:o_wronly unix:o_creat how)
+ (logior unix:O_WRONLY unix:O_CREAT how)
(logand (st-mode st) #o777))
- (unix-try fchmod out (st-mode st))
- (unix-try utimes to (st-atime st) 0 (st-mtime st) 0)
+ (sys-fchmod out (st-mode st))
+ (sys-utimes to (st-atime st) 0 (st-mtime st) 0)
(with-errno-handlers ()
- (unix-try fchown out (st-uid st) (st-gid st))
+ (sys-fchown out (st-uid st) (st-gid st))
(eperm nil))
(with-buffer (buf 16384)
(loop
- (let ((n (unix-try read in buf 16384)))
+ (let ((n (sys-read in buf 16384)))
(when (zerop n)
(return))
- (unix-try write out buf 0 n))))))))
+ (sys-write out buf 0 n))))))))
;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / blobdiff