(defpackage #:mdw.unix
(:use #:common-lisp #:mdw.base #:mdw.collect)
(:export #:unix-error #:errno-value #:with-errno-handlers
- #:unix-try-func #:unix-try
- #:stat
+ #:syscall #:syscall*
+ #:stat #:sys-stat
+ #:sys-open #:sys-close #:sys-read #:sys-write
+ #:sys-chown #:sys-fchown #:sys-chmod #:sys-fchmod
+ #:sys-utimes #:sys-unlink #:sys-rename
+ #:sys-gettimeofday #:sys-gethostname
#:with-unix-open #:copy-file))
(in-package #:mdw.unix)
(setf ,var (system:allocate-system-memory ,lenvar))
,@body)
(when ,var (system:deallocate-system-memory ,var ,lenvar))))))
+
(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."))
+
(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)))))
+
(defmacro with-errno-handlers ((&key cond
(errno (gensym))
errstring)
(progn ,@(cdr cl)))))
clauses
labels)))))))))
-(defun unix-try-func (name func &rest args)
+
+(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."
(multiple-value-call (lambda (rc &rest stuff)
: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)
+(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))
+
+(macrolet ((doit (doc 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)
+ ,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)))
+(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-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 (intern (format nil "SYS-~:@(~A~)" name)))
+ (unixname (intern (format nil "UNIX-~:@(~A~)" name) :unix)))
+ `(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))
+
(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
`(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)))))
+
(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)
+ (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