mdw@git.distorted.org.uk Git - lisp/blob - unix.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; $Id$
   4 ;;;
   5 ;;; Unix system call stuff
   6 ;;;
   7 ;;; (c) 2005 Straylight/Edgeware
   8 ;;;
   9
  10 ;;;----- Licensing notice ---------------------------------------------------
  11 ;;;
  12 ;;; This program is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; This program is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with this program; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (defpackage #:mdw.unix
  27   (:use #:common-lisp #:mdw.base #:collect)
  28   (:export #:unix-error #:errno-value #:with-errno-handlers
  29            #:syscall #:syscall*
  30            #:stat #:sys-stat
  31            #:sys-open #:sys-close #:sys-read #:sys-write
  32            #:sys-chown #:sys-fchown #:sys-chmod #:sys-fchmod
  33            #:sys-utimes #:sys-unlink #:sys-rename
  34            #:sys-gettimeofday #:sys-gethostname
  35            #:with-unix-open #:copy-file))
  36 (in-package #:mdw.unix)
  37
  38 (defmacro with-buffer ((var len) &body body)
  39   "Evaluate BODY with VAR bound to a pointer (a SAP, if you must know) to a
  40    buffer of LEN bytes."
  41   (with-gensyms lenvar
  42     `(let ((,lenvar ,len)
  43            (,var nil))
  44        (unwind-protect
  45            (progn
  46              (setf ,var (system:allocate-system-memory ,lenvar))
  47              ,@body)
  48          (when ,var (system:deallocate-system-memory ,var ,lenvar))))))
  49
  50 (define-condition unix-error (error)
  51   ((func :initform 'unknown :initarg :func :reader unix-error-func)
  52    (args :initform nil :initarg :args :reader unix-error-args)
  53    (errno :initform 0 :initarg :errno :reader unix-error-errno))
  54   (:report (lambda (c s)
  55              (format s "Error from ~A: ~A (~D)"
  56                      (cons (unix-error-func c) (unix-error-args c))
  57                      (unix:get-unix-error-msg (unix-error-errno c))
  58                      (unix-error-errno c))))
  59   (:documentation "Reports an error from a Unix system call."))
  60
  61 (compile-time-defun errno-value (err)
  62     "Returns the numeric value corresponding to an errno name."
  63     (etypecase err
  64       (integer err)
  65       (symbol (symbol-value (intern (symbol-name err) :unix)))))
  66
  67 (defmacro with-errno-handlers ((&key cond
  68                                      (errno (gensym))
  69                                      errstring)
  70                                form &rest clauses)
  71   "Evaluate FORM but trap Unix errors according to CLAUSES.  Each clause has
  72    the form of a `case' clause, but may contain symbolic errno names as well
  73    as numbers."
  74   (flet ((fix (sw)
  75            (cond ((eq sw t) 't)
  76                  ((atom sw) (list (errno-value sw)))
  77                  (t (mapcar #'errno-value sw)))))
  78     (with-gensyms (block condtmp formfunc)
  79       (let ((labels (mapcar (lambda (cl)
  80                               (declare (ignore cl))
  81                               (gensym))
  82                             clauses)))
  83         `(let (,@(when cond `(,cond))
  84                ,@(when errstring `(,errstring))
  85                ,errno
  86                (,formfunc (lambda () ,form)))
  87            (block ,block
  88              (tagbody
  89                (handler-bind
  90                    ((unix-error
  91                       (lambda (,condtmp)
  92                         (setf ,errno (unix-error-errno ,condtmp))
  93                         ,@(when cond
  94                             `((setf ,cond ,condtmp)))
  95                         ,@(when errstring
  96                             `((setf ,errstring
  97                                     (unix:get-unix-error-msg ,errno))))
  98                         (case ,errno
  99                           ,@(mapcar (lambda (cl lab)
 100                                       `(,(fix (car cl)) (go ,lab)))
 101                                     clauses
 102                                     labels)))))
 103                  (return-from ,block (funcall ,formfunc)))
 104                ,@(collecting ()
 105                    (mapc (lambda (cl lab)
 106                            (collect lab)
 107                            (collect `(return-from ,block
 108                                        (progn ,@(cdr cl)))))
 109                          clauses
 110                          labels)))))))))
 111
 112 (defun syscall* (name func &rest args)
 113   "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
 114    signal the unix-error condition, with NAME and ARGS."
 115   (multiple-value-call (lambda (rc &rest stuff)
 116                          (unless rc
 117                            (error 'unix-error
 118                                   :func name
 119                                   :args args
 120                                   :errno (car stuff)))
 121                          (apply #'values rc stuff))
 122                        (apply func args)))
 123 (defmacro syscall (func &rest args)
 124   "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
 125    signal the unix-error condition, with FUNC and ARGS."
 126   `(syscall* ',func
 127    #',func ,@args))
 128
 129 (macrolet ((doit (doc slots)
 130              `(defstruct (stat (:predicate statp)
 131                                (:conc-name st-)
 132                                (:constructor %make-stat-boa ,slots))
 133                 ,doc
 134                 ,@slots)))
 135   (doit
 136    "Structure representing all the useful information `stat' returns about a
 137    file."
 138    (dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks)))
 139 (defun sys-stat (file)
 140   "Return information about FILE in a structure rather than as inconvenient
 141    multiple values."
 142   (multiple-value-call
 143       (lambda (rc &rest results)
 144         (unless rc
 145           (error 'unix-error
 146                  :func 'sys-stat :args (list file)
 147                  :error (car results)))
 148         (apply #'%make-stat-boa results))
 149     (unix:unix-stat file)))
 150
 151 (defmacro defsyscall (name)
 152   (let ((sysname (intern (format nil "SYS-~:@(~A~)" name)))
 153         (unixname (intern (format nil "UNIX-~:@(~A~)" name) :unix)))
 154     `(defun ,sysname (&rest args)
 155        (apply #'syscall* ',sysname #',unixname args))))
 156
 157 (macrolet ((defsys (&rest names)
 158              `(progn ,@(mapcar (lambda (name)
 159                                  `(defsyscall ,name))
 160                                names))))
 161   (defsys open close read write
 162           chown fchown chmod fchmod utimes
 163           unlink rename
 164           gethostname gettimeofday))
 165
 166 (defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body)
 167   "Evaluate BODY with FD bound to a file descriptor obtained from a Unix
 168    `open' syscall with arguments FILE, HOW and MODE.  Close the file
 169    descriptor when BODY is done."
 170   `(let (,fd)
 171      (unwind-protect
 172          (progn
 173            (setf ,fd (sys-open ,file ,how ,mode))
 174            ,@body)
 175        (when ,fd (sys-close ,fd)))))
 176
 177 (defun copy-file (from to &optional (how 0))
 178   "Make a copy of the file FROM called TO.  The copy has the same permissions
 179    and timestamps (except for ctime) and attempts to have the same owner and
 180    group as the original."
 181   (let ((st (sys-stat from)))
 182     (with-unix-open (in from unix:O_RDONLY)
 183       (with-unix-open (out
 184                        to
 185                        (logior unix:O_WRONLY unix:O_CREAT how)
 186                        (logand (st-mode st) #o777))
 187         (sys-fchmod out (st-mode st))
 188         (sys-utimes to (st-atime st) 0 (st-mtime st) 0)
 189         (with-errno-handlers ()
 190           (sys-fchown out (st-uid st) (st-gid st))
 191           (eperm nil))
 192         (with-buffer (buf 16384)
 193           (loop
 194             (let ((n (sys-read in buf 16384)))
 195               (when (zerop n)
 196                 (return))
 197               (sys-write out buf 0 n))))))))
 198
 199 ;;;----- That's all, folks --------------------------------------------------