| 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 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 | (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 versions, |
| 113 | if any. If a problem occurs during this stage, everything is rewound and no |
| 114 | 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 -------------------------------------------------- |