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 #:mdw.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 #:mdw.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 try
  49 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   (when (probe-file file)
  71     (sys-unlink file)))
  72
  73 (defun rename-file-without-moaning (old new)
  74   "Rename OLD to NEW, ignoring errors, and without doing any stupid name
  75 mangling."
  76   (when (probe-file old)
  77     (sys-rename old new)))
  78
  79 (defun safely-unwind (trail)
  80   "Roll back the TRAIL of operations."
  81   (dolist (job trail)
  82     (ecase (car job)
  83       (:shunt (destructuring-bind (tag new file old) job
  84                 (declare (ignore tag file))
  85                 (delete-file-without-moaning old)
  86                 (delete-file-without-moaning new)))
  87       (:delete)
  88       (:rmtmp (destructuring-bind (tag file) job
  89                 (declare (ignore tag))
  90                 (delete-file-without-moaning file)))
  91       (:revert (destructuring-bind (tag old new) job
  92                  (declare (ignore tag))
  93                  (rename-file-without-moaning old new))))))
  94
  95 (defun safely-reset (safe)
  96   "Reset SAFE to its initial state."
  97   (setf (safely-streams safe) nil)
  98   (setf (safely-trail safe) nil))
  99
 100 (defun safely-bail (safe)
 101   "Abort the operations in SAFE, unwinding all the things that have been
 102 done.  Streams are closed, new files are removed."
 103   (dolist (stream (safely-streams safe))
 104     (close stream :abort t))
 105   (safely-unwind (safely-trail safe))
 106   (safely-reset safe))
 107
 108 (defun safely-commit (safe)
 109   "Commit SAFE.  The files deleted by safely-delete-file are deleted; the
 110 files created by safely-open-output-stream are renamed over the old versions,
 111 if any.  If a problem occurs during this stage, everything is rewound and no
 112 changes are made."
 113   (let ((trail (safely-trail safe))
 114         (revert nil)
 115         (cleanup nil))
 116     (unwind-protect
 117         (progn
 118           (dolist (stream (safely-streams safe))
 119             (close stream))
 120           (loop
 121             (unless trail
 122               (return))
 123               (let ((job (pop trail)))
 124                 (ecase (car job)
 125                   (:shunt (destructuring-bind (tag new file old) job
 126                             (declare (ignore tag))
 127                             (push `(:rmtmp ,old) cleanup)
 128                             (push `(:rmtmp ,new) revert)
 129                             (if (probe-file file)
 130                                 (progn
 131                                   (copy-file file old)
 132                                   (push `(:revert ,old ,file) revert))
 133                                 (push `(:rmtmp ,file) revert))
 134                             (sys-rename new file)))
 135                   (:delete (destructuring-bind (tag file old) job
 136                              (declare (ignore tag))
 137                              (push `(:revert ,old ,file) revert)
 138                              (sys-rename file old)
 139                              (push `(:rmtmp old) cleanup))))))
 140           (setf revert nil))
 141       (safely-unwind trail)
 142       (safely-unwind revert)
 143       (safely-unwind cleanup)
 144       (safely-reset safe))))
 145
 146 (defmacro safely ((safe &key) &body body)
 147   "Do stuff within the BODY safely.  If BODY completes without errors, the
 148 SAFE is committed; otherwise it's bailed."
 149   `(let ((,safe (make-safely)))
 150      (unwind-protect
 151          (progn
 152            ,@body
 153            (safely-commit ,safe)
 154            (setf ,safe nil))
 155        (when ,safe
 156          (safely-bail ,safe)))))
 157
 158 (defmacro safely-writing ((stream file &rest open-args) &body body)
 159   "Simple macro for writing a single file safely.  STREAM is opened onto a
 160 temporary file, and if BODY completes, it is renamed to FILE."
 161   (with-gensyms safe
 162     `(safely (,safe)
 163        (let ((,stream (apply #'safely-open-output-stream
 164                              ,safe ,file ,open-args)))
 165          ,@body))))
 166
 167 ;;;----- That's all, folks --------------------------------------------------