X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/bf0a8c394bdf34895ad53771665f70c3b80e272e..813da880d2d77f04ea623f426d543d298528f967:/unix.lisp diff --git a/unix.lisp b/unix.lisp index 4465740..254540d 100644 --- a/unix.lisp +++ b/unix.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; Unix system call stuff ;;; ;;; (c) 2005 Straylight/Edgeware @@ -13,40 +11,33 @@ ;;; 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 #: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) @@ -58,19 +49,21 @@ buffer of LEN bytes." (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))) @@ -109,9 +102,10 @@ numbers." 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 @@ -120,24 +114,33 @@ signal the unix-error condition, with NAME and ARGS." :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 @@ -148,13 +151,16 @@ multiple values." (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 @@ -162,10 +168,11 @@ multiple values." 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 @@ -173,17 +180,18 @@ when BODY is done." ,@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))