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

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; $Id$
   4 ;;;
   5 ;;; Safely modify collections of files
   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 #:safely
  27   (:use #:common-lisp #:mdw.base #:mdw.unix)
  28   (:export #:safely #:safely-close #:safely-delete-file
  29            #:safely-open-output-stream #:safely-bail #:safely-commit
  30            #:safely-writing))
  31 (in-package #:safely)
  32
  33 (defstruct (safely (:predicate safelyp))
  34   "Stores information about how to commit or undo safe writes."
  35   (streams nil)
  36   (trail nil))
  37
  38 (defun safely-close (safe stream)
  39   "Make sure that STREAM is closed when SAFE is finished."
  40   (push stream (safely-streams safe)))
  41
  42 (defun safely-delete-file (safe file)
  43   "Delete FILE when SAFE is committed."
  44   (push `(:delete ,file ,(fresh-file-name file "del")) (safely-trail safe)))
  45
  46 (defun fresh-file-name (base tag)
  47   "Return a fresh file name constructed from BASE and TAG in the current
  48    directory.  Do not assume that this filename will be good by the time you
  49    try to create the file."
  50   (let ((name (format nil "~A.~A-~X"
  51                       base tag (random most-positive-fixnum))))
  52     (if (probe-file name) (fresh-file-name base tag) name)))
  53
  54 (defun safely-open-output-stream (safe file &rest open-args)
  55   "Create an output stream which will be named FILE when SAFE is committed.
  56    Other OPEN-ARGS are passed to open."
  57   (let* ((new (fresh-file-name file "new"))
  58          (stream (apply #'open
  59                         new
  60                         :direction :output
  61                         :if-exists :error
  62                         open-args)))
  63     (safely-close safe stream)
  64     (push `(:shunt ,new ,file ,(fresh-file-name file "old"))
  65           (safely-trail safe))
  66     stream))
  67
  68 (defun delete-file-without-moaning (file)
  69   "Delete the FILE, ignoring errors."
  70   (with-errno-handlers ()
  71       (sys-unlink file)
  72     (ENOENT nil)))
  73
  74 (defun rename-file-without-moaning (old new)
  75   "Rename OLD to NEW, ignoring errors, and without doing any stupid name
  76    mangling."
  77   (with-errno-handlers ()
  78       (sys-rename old new)
  79     (ENOENT nil)))
  80
  81 (defun safely-unwind (trail)
  82   "Roll back the TRAIL of operations."
  83   (dolist (job trail)
  84     (ecase (car job)
  85       (:shunt (destructuring-bind (tag new file old) job
  86                 (declare (ignore tag file))
  87                 (delete-file-without-moaning old)
  88                 (delete-file-without-moaning new)))
  89       (:delete)
  90       (:rmtmp (destructuring-bind (tag file) job
  91                 (declare (ignore tag))
  92                 (delete-file-without-moaning file)))
  93       (:revert (destructuring-bind (tag old new) job
  94                  (declare (ignore tag))
  95                  (rename-file-without-moaning old new))))))
  96
  97 (defun safely-reset (safe)
  98   "Reset SAFE to its initial state."
  99   (setf (safely-streams safe) nil)
 100   (setf (safely-trail safe) nil))
 101
 102 (defun safely-bail (safe)
 103   "Abort the operations in SAFE, unwinding all the things that have been
 104    done.  Streams are closed, new files are removed."
 105   (dolist (stream (safely-streams safe))
 106     (close stream :abort t))
 107   (safely-unwind (safely-trail safe))
 108   (safely-reset safe))
 109
 110 (defun safely-commit (safe)
 111   "Commit SAFE.  The files deleted by safely-delete-file are deleted; the
 112    files created by safely-open-output-stream are renamed over the old
 113    versions, if any.  If a problem occurs during this stage, everything is
 114    rewound and no changes are made."
 115   (let ((trail (safely-trail safe))
 116         (revert nil)
 117         (cleanup nil))
 118     (unwind-protect
 119         (progn
 120           (dolist (stream (safely-streams safe))
 121             (close stream))
 122           (loop
 123             (unless trail
 124               (return))
 125               (let ((job (pop trail)))
 126                 (ecase (car job)
 127                   (:shunt (destructuring-bind (tag new file old) job
 128                             (declare (ignore tag))
 129                             (push `(:rmtmp ,old) cleanup)
 130                             (push `(:rmtmp ,new) revert)
 131                             (if (probe-file file)
 132                                 (progn
 133                                   (copy-file file old)
 134                                   (push `(:revert ,old ,file) revert))
 135                                 (push `(:rmtmp ,file) revert))
 136                             (sys-rename new file)))
 137                   (:delete (destructuring-bind (tag file old) job
 138                              (declare (ignore tag))
 139                              (push `(:revert ,old ,file) revert)
 140                              (sys-rename file old)
 141                              (push `(:rmtmp old) cleanup))))))
 142           (setf revert nil))
 143       (safely-unwind trail)
 144       (safely-unwind revert)
 145       (safely-unwind cleanup)
 146       (safely-reset safe))))
 147
 148 (defmacro safely ((safe &key) &body body)
 149   "Do stuff within the BODY safely.  If BODY completes without errors, the
 150    SAFE is committed; otherwise it's bailed."
 151   `(let ((,safe (make-safely)))
 152      (unwind-protect
 153          (progn
 154            ,@body
 155            (safely-commit ,safe)
 156            (setf ,safe nil))
 157        (when ,safe
 158          (safely-bail ,safe)))))
 159
 160 (defmacro safely-writing ((stream file &rest open-args) &body body)
 161   "Simple macro for writing a single file safely.  STREAM is opened onto a
 162    temporary file, and if BODY completes, it is renamed to FILE."
 163   (with-gensyms safe
 164     `(safely (,safe)
 165        (let ((,stream (apply #'safely-open-output-stream
 166                              ,safe ,file ,open-args)))
 167          ,@body))))
 168
 169 ;;;----- That's all, folks --------------------------------------------------