-;;; -*-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
- #: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))
+ (: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-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)))
clauses
labels)))))))))
+(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)))
+
+(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))
+ signal the unix-error condition, with FUNC and ARGS."
+ `(syscall* ',func
+ #',func ,@args))
+(export '(stat statp))
(macrolet ((doit (doc slots)
- `(defstruct (stat (:predicate statp)
- (:conc-name st-)
- (:constructor %make-stat-boa ,slots))
- ,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)))
+ "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 values."
(multiple-value-call
(lambda (rc &rest results)
(unless rc
(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))))
+ (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)
+ `(progn ,@(mapcar (lambda (name)
`(defsyscall ,name))
names))))
(defsys open close read write
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
,@body)
(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."
+ 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)
(logand (st-mode st) #o777))
- (sys-fchmod out (st-mode st))
+ (sys-fchmod out (st-mode st))
(sys-utimes to (st-atime st) 0 (st-mtime st) 0)
(with-errno-handlers ()
(sys-fchown out (st-uid st) (st-gid st))