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

   1 ;;; -*-lisp-*0
   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 #:mdw.collect)
  28   (:export #:unix-error #:errno-value #:with-errno-handlers
  29            #:unix-try-func #:unix-try
  30            #:stat
  31            #:with-unix-open #:copy-file))
  32 (in-package #:mdw.unix)
  33
  34 (defmacro with-buffer ((var len) &body body)
  35   "Evaluate BODY with VAR bound to a pointer (a SAP, if you must know) to a
  36 buffer of LEN bytes."
  37   (with-gensyms lenvar
  38     `(let ((,lenvar ,len)
  39            (,var nil))
  40        (unwind-protect
  41            (progn
  42              (setf ,var (system:allocate-system-memory ,lenvar))
  43              ,@body)
  44          (when ,var (system:deallocate-system-memory ,var ,lenvar))))))
  45 (define-condition unix-error (error)
  46   ((func :initform 'unknown :initarg :func :reader unix-error-func)
  47    (args :initform nil :initarg :args :reader unix-error-args)
  48    (errno :initform 0 :initarg :errno :reader unix-error-errno))
  49   (:report (lambda (c s)
  50              (format s "Error from ~A: ~A (~D)"
  51                      (cons (unix-error-func c) (unix-error-args c))
  52                      (unix:get-unix-error-msg (unix-error-errno c))
  53                      (unix-error-errno c))))
  54   (:documentation "Reports an error from a Unix system call."))
  55 (compile-time-defun errno-value (err)
  56     "Returns the numeric value corresponding to an errno name."
  57     (etypecase err
  58       (integer err)
  59       (symbol (symbol-value (intern (symbol-name err) :unix)))))
  60 (defmacro with-errno-handlers ((&key cond
  61                                      (errno (gensym))
  62                                      errstring)
  63                                form &rest clauses)
  64   "Evaluate FORM but trap Unix errors according to CLAUSES.  Each clause has
  65 the form of a `case' clause, but may contain symbolic errno names as well as
  66 numbers."
  67   (flet ((fix (sw)
  68            (cond ((eq sw t) 't)
  69                  ((atom sw) (list (errno-value sw)))
  70                  (t (mapcar #'errno-value sw)))))
  71     (with-gensyms (block condtmp formfunc)
  72       (let ((labels (mapcar (lambda (cl)
  73                               (declare (ignore cl))
  74                               (gensym))
  75                             clauses)))
  76         `(let (,@(when cond `(,cond))
  77                ,@(when errstring `(,errstring))
  78                ,errno
  79                (,formfunc (lambda () ,form)))
  80            (block ,block
  81              (tagbody
  82                (handler-bind
  83                    ((unix-error
  84                       (lambda (,condtmp)
  85                         (setf ,errno (unix-error-errno ,condtmp))
  86                         ,@(when cond
  87                             `((setf ,cond ,condtmp)))
  88                         ,@(when errstring
  89                             `((setf ,errstring
  90                                     (unix:get-unix-error-msg ,errno))))
  91                         (case ,errno
  92                           ,@(mapcar (lambda (cl lab)
  93                                       `(,(fix (car cl)) (go ,lab)))
  94                                     clauses
  95                                     labels)))))
  96                  (return-from ,block (funcall ,formfunc)))
  97                ,@(collecting ()
  98                    (mapc (lambda (cl lab)
  99                            (collect lab)
 100                            (collect `(return-from ,block
 101                                        (progn ,@(cdr cl)))))
 102                          clauses
 103                          labels)))))))))
 104 (defun unix-try-func (name func &rest args)
 105   "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
 106 signal the unix-error condition, with NAME and ARGS."
 107   (multiple-value-call (lambda (rc &rest stuff)
 108                          (unless rc
 109                            (error 'unix-error
 110                                   :func name
 111                                   :args args
 112                                   :errno (car stuff)))
 113                          (apply #'values rc stuff))
 114                        (apply func args)))
 115 (defmacro unix-try (syscall &rest args)
 116   "Wrapper for unix-try-func.  Call Unix system-call SYSCALL (without the
 117 `unix-' prefix or other stuff), passing it ARGS."
 118   (let ((func (intern (format nil "UNIX-~A" (symbol-name syscall)) :unix)))
 119     `(unix-try-func ',syscall #',func ,@args)))
 120 (macrolet ((doit (slots)
 121              `(defstruct (stat (:predicate statp)
 122                                (:conc-name st-)
 123                                (:constructor %make-stat-boa ,slots))
 124                 "Structure representing all the useful information `stat'
 125 returns about a file."
 126                 ,@slots)))
 127   (doit (dev ino mode nlink uid gid rdev size
 128          atime mtime ctime blksize blocks)))
 129 (defun stat (file)
 130   "Return information about FILE in a structure rather than as inconvenient
 131 multiple values."
 132   (multiple-value-call (lambda (rc &rest results)
 133                          (unless rc
 134                            (error 'unix-error :func 'stat :args (list file)
 135                                   :error (car results)))
 136                          (apply #'%make-stat-boa results))
 137                        (unix:unix-stat file)))
 138 (defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body)
 139   "Evaluate BODY with FD bound to a file descriptor obtained from a Unix
 140 `open' syscall with arguments FILE, HOW and MODE.  Close the file descriptor
 141 when BODY is done."
 142   `(let (,fd)
 143      (unwind-protect
 144          (progn
 145            (setf ,fd (unix-try open ,file ,how ,mode))
 146            ,@body)
 147        (when ,fd (unix-try close ,fd)))))
 148 (defun copy-file (from to &optional (how 0))
 149   "Make a copy of the file FROM called TO.  The copy has the same permissions
 150 and timestamps (except for ctime) and attempts to have the same owner and
 151 group as the original."
 152   (let ((st (stat from)))
 153     (with-unix-open (in from unix:o_rdonly)
 154       (with-unix-open (out
 155                        to
 156                        (logior unix:o_wronly unix:o_creat how)
 157                        (logand (st-mode st) #o777))
 158         (unix-try fchmod out (st-mode st))
 159         (unix-try utimes to (st-atime st) 0 (st-mtime st) 0)
 160         (with-errno-handlers ()
 161           (unix-try fchown out (st-uid st) (st-gid st))
 162           (eperm nil))
 163         (with-buffer (buf 16384)
 164           (loop
 165             (let ((n (unix-try read in buf 16384)))
 166               (when (zerop n)
 167                 (return))
 168               (unix-try write out buf 0 n))))))))
 169
 170 ;;;----- That's all, folks --------------------------------------------------