chiark - git - mdw - lisp/blob - unix.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Unix system call stuff
   4 ;;;
   5 ;;; (c) 2005 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 2 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software Foundation,
  22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23
  24 (defpackage #:mdw.unix
  25   (:use #:common-lisp #:mdw.base #:collect))
  26 (in-package #:mdw.unix)
  27
  28 (defmacro with-buffer ((var len) &body body)
  29   "Evaluate BODY with VAR bound to a pointer (a SAP, if you must know) to a
  30    buffer of LEN bytes."
  31   (with-gensyms lenvar
  32     `(let ((,lenvar ,len)
  33            (,var nil))
  34        (unwind-protect
  35            (progn
  36              (setf ,var (system:allocate-system-memory ,lenvar))
  37              ,@body)
  38          (when ,var (system:deallocate-system-memory ,var ,lenvar))))))
  39
  40 (export '(unix-error unix-error-func unix-error-args unix-error-errno))
  41 (define-condition unix-error (error)
  42   ((func :initform 'unknown :initarg :func :reader unix-error-func)
  43    (args :initform nil :initarg :args :reader unix-error-args)
  44    (errno :initform 0 :initarg :errno :reader unix-error-errno))
  45   (:report (lambda (c s)
  46              (format s "Error from ~A: ~A (~D)"
  47                      (cons (unix-error-func c) (unix-error-args c))
  48                      (unix:get-unix-error-msg (unix-error-errno c))
  49                      (unix-error-errno c))))
  50   (:documentation "Reports an error from a Unix system call."))
  51
  52 (export 'errno-value)
  53 (compile-time-defun errno-value (err)
  54   "Returns the numeric value corresponding to an errno name."
  55   (etypecase err
  56     (integer err)
  57     (symbol (symbol-value (intern (symbol-name err) :unix)))))
  58
  59 (export 'with-errno-handlers)
  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
  66    as 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
 105 (export 'syscall*)
 106 (defun syscall* (name func &rest args)
 107   "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
 108    signal the unix-error condition, with NAME and ARGS."
 109   (multiple-value-call (lambda (rc &rest stuff)
 110                          (unless rc
 111                            (error 'unix-error
 112                                   :func name
 113                                   :args args
 114                                   :errno (car stuff)))
 115                          (apply #'values rc stuff))
 116                        (apply func args)))
 117
 118 (export 'syscall)
 119 (defmacro syscall (func &rest args)
 120   "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
 121    signal the unix-error condition, with FUNC and ARGS."
 122   `(syscall* ',func
 123    #',func ,@args))
 124
 125 (export '(stat statp))
 126 (macrolet ((doit (doc slots)
 127              `(progn
 128                 (export ',(mapcar (lambda (slot) (symbolicate 'st- slot))
 129                                   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
 140 (export 'sys-stat)
 141 (defun sys-stat (file)
 142   "Return information about FILE in a structure rather than as inconvenient
 143    multiple values."
 144   (multiple-value-call
 145       (lambda (rc &rest results)
 146         (unless rc
 147           (error 'unix-error
 148                  :func 'sys-stat :args (list file)
 149                  :error (car results)))
 150         (apply #'%make-stat-boa results))
 151     (unix:unix-stat file)))
 152
 153 (defmacro defsyscall (name)
 154   (let ((sysname (symbolicate 'sys- name))
 155         (unixname (let ((*package* (find-package :unix)))
 156                     (symbolicate 'unix- name))))
 157     `(progn
 158        (export ',sysname)
 159        (defun ,sysname (&rest args)
 160          (apply #'syscall* ',sysname #',unixname args)))))
 161
 162 (macrolet ((defsys (&rest names)
 163              `(progn ,@(mapcar (lambda (name)
 164                                  `(defsyscall ,name))
 165                                names))))
 166   (defsys open close read write
 167           chown fchown chmod fchmod utimes
 168           unlink rename
 169           gethostname gettimeofday))
 170
 171 (export 'with-unix-open)
 172 (defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body)
 173   "Evaluate BODY with FD bound to a file descriptor obtained from a Unix
 174    `open' syscall with arguments FILE, HOW and MODE.  Close the file
 175    descriptor when BODY is done."
 176   `(let (,fd)
 177      (unwind-protect
 178          (progn
 179            (setf ,fd (sys-open ,file ,how ,mode))
 180            ,@body)
 181        (when ,fd (sys-close ,fd)))))
 182
 183 (export 'copy-file)
 184 (defun copy-file (from to &optional (how 0))
 185   "Make a copy of the file FROM called TO.  The copy has the same permissions
 186    and timestamps (except for ctime) and attempts to have the same owner and
 187    group as the original."
 188   (let ((st (sys-stat from)))
 189     (with-unix-open (in from unix:O_RDONLY)
 190       (with-unix-open (out
 191                        to
 192                        (logior unix:O_WRONLY unix:O_CREAT how)
 193                        (logand (st-mode st) #o777))
 194         (sys-fchmod out (st-mode st))
 195         (sys-utimes to (st-atime st) 0 (st-mtime st) 0)
 196         (with-errno-handlers ()
 197           (sys-fchown out (st-uid st) (st-gid st))
 198           (eperm nil))
 199         (with-buffer (buf 16384)
 200           (loop
 201             (let ((n (sys-read in buf 16384)))
 202               (when (zerop n)
 203                 (return))
 204               (sys-write out buf 0 n))))))))
 205
 206 ;;;----- That's all, folks --------------------------------------------------