X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/861345b43569790e39df152c6b495b14e7dab360..0eed4749891adf0a7be89e786b8968ee805a8d41:/unix.lisp diff --git a/unix.lisp b/unix.lisp index 8f9cd3e..be823f0 100644 --- a/unix.lisp +++ b/unix.lisp @@ -1,4 +1,4 @@ -;;; -*-lisp-*0 +;;; -*-lisp-*- ;;; ;;; $Id$ ;;; @@ -13,35 +13,40 @@ ;;; 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) + (:use #:common-lisp #:mdw.base #: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) (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)))))) + (define-condition unix-error (error) ((func :initform 'unknown :initarg :func :reader unix-error-func) (args :initform nil :initarg :args :reader unix-error-args) @@ -52,18 +57,20 @@ buffer of LEN bytes." (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) 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))) @@ -101,9 +108,10 @@ numbers." (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." + signal the unix-error condition, with NAME and ARGS." (multiple-value-call (lambda (rc &rest stuff) (unless rc (error 'unix-error @@ -112,59 +120,80 @@ signal the unix-error condition, with NAME and ARGS." :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." + ,doc ,@slots))) - (doit (dev ino mode nlink uid gid rdev size - atime mtime ctime blksize blocks))) -(defun stat (file) + (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 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 (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 -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))))) + (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 --------------------------------------------------