| 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) |
| 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 | #+(or cmu sbcl) |
| 34 | (eval-when (:compile-toplevel :execute) |
| 35 | (import #+cmu '(ext:unix-namestring unix:unix-link) |
| 36 | #+sbcl '(sb-ext:native-namestring))) |
| 37 | #+cmu |
| 38 | (progn |
| 39 | (declaim (inline unix-namestring)) |
| 40 | (defun native-namestring (pathname &key as-file) |
| 41 | (declare (ignore as-file)) |
| 42 | (unix-namestring pathname nil))) |
| 43 | |
| 44 | (defstruct (safely (:predicate safelyp)) |
| 45 | "Stores information about how to commit or undo safe writes." |
| 46 | (streams nil) |
| 47 | (trail nil)) |
| 48 | |
| 49 | (defun safely-close (safe stream) |
| 50 | "Make sure that STREAM is closed when SAFE is finished." |
| 51 | (push stream (safely-streams safe))) |
| 52 | |
| 53 | (defun safely-delete-file (safe file) |
| 54 | "Delete FILE when SAFE is committed." |
| 55 | (push `(:delete ,file) (safely-trail safe))) |
| 56 | |
| 57 | (defun generate-fresh-file-name (base tag &optional func) |
| 58 | "Return a fresh file name constructed from BASE (a filespec) and TAG (some |
| 59 | short descriptive string). The generated name has the same directory and |
| 60 | type as the BASE name, but a different name. |
| 61 | |
| 62 | If FUNC is non-nil, then it is a function to call on the generated file |
| 63 | name: generate-fresh-file-name runs in a loop, calling FUNC with generated |
| 64 | file names until FUNC returns non-nil, at which point generate-fresh- |
| 65 | file-name returns two values: the generated name, and the result of FUNC. |
| 66 | generate-fresh-file-name catches errors of type file-error from FUNC, and |
| 67 | just tries again with a new name. |
| 68 | |
| 69 | If FUNC is nil, it's treated the same as a function which always returns |
| 70 | t. |
| 71 | |
| 72 | This is inspired by a similar facility in scsh." |
| 73 | (let ((base (pathname base))) |
| 74 | (dotimes (i 256 |
| 75 | (error "Gave up trying to find a temporary ~A file for ~S." |
| 76 | tag base)) |
| 77 | (let* ((new (merge-pathnames |
| 78 | (make-pathname |
| 79 | :name (format nil "~A-~A-~X" |
| 80 | (pathname-name base) |
| 81 | tag |
| 82 | (random most-positive-fixnum))) |
| 83 | base)) |
| 84 | (ret (and (not (probe-file new)) |
| 85 | (if func |
| 86 | (handler-case (funcall func new) |
| 87 | (file-error (cond) |
| 88 | (unless (pathname-match-p |
| 89 | (file-error-pathname cond) |
| 90 | new) |
| 91 | (error cond)) |
| 92 | nil)) |
| 93 | t)))) |
| 94 | (when ret |
| 95 | (return (values new ret))))))) |
| 96 | |
| 97 | (defun safely-open-output-stream (safe file &rest open-args) |
| 98 | "Create an output stream which will be named FILE when SAFE is committed. |
| 99 | Other OPEN-ARGS are passed to open." |
| 100 | (multiple-value-bind |
| 101 | (name stream) |
| 102 | (generate-fresh-file-name file "new" |
| 103 | (lambda (name) |
| 104 | (apply #'open name |
| 105 | :direction :output |
| 106 | :if-exists nil |
| 107 | open-args))) |
| 108 | (safely-close safe stream) |
| 109 | (push `(:shunt ,name ,file) |
| 110 | (safely-trail safe)) |
| 111 | stream)) |
| 112 | |
| 113 | #+clisp |
| 114 | (progn |
| 115 | (ffi:def-call-out %rename (:name "rename") |
| 116 | (:language :stdc) |
| 117 | (:library "libc.so.6") |
| 118 | (:arguments (from ffi:c-string) |
| 119 | (to ffi:c-string)) |
| 120 | (:return-type ffi:int))) |
| 121 | |
| 122 | (declaim (inline rename)) |
| 123 | (defun rename (old new) |
| 124 | #-clisp |
| 125 | (let ((target (make-pathname :directory '(:relative) |
| 126 | :defaults new))) |
| 127 | (rename-file old target)) |
| 128 | |
| 129 | #+clisp |
| 130 | (let ((rc (%rename (namestring old) (namestring new)))) |
| 131 | (when (= rc -1) |
| 132 | (error "Failed to rename ~S to ~S: ~A" old new (posix:strerror))))) |
| 133 | |
| 134 | (defun delete-file-without-moaning (file) |
| 135 | "Delete the FILE, ignoring errors." |
| 136 | (handler-case (delete-file file) |
| 137 | (file-error () nil))) |
| 138 | |
| 139 | (defun rename-file-without-moaning (old new) |
| 140 | "Rename OLD to NEW, ignoring errors, and without doing any stupid name |
| 141 | mangling." |
| 142 | (handler-case (rename old new) |
| 143 | (file-error () nil))) |
| 144 | |
| 145 | (defun safely-unwind (trail) |
| 146 | "Roll back the TRAIL of operations." |
| 147 | (dolist (job trail) |
| 148 | (ecase (car job) |
| 149 | (:shunt (destructuring-bind (new file) (cdr job) |
| 150 | (declare (ignore file)) |
| 151 | (delete-file-without-moaning new))) |
| 152 | (:delete) |
| 153 | (:rmtmp (destructuring-bind (file) (cdr job) |
| 154 | (delete-file-without-moaning file))) |
| 155 | (:revert (destructuring-bind (old new) (cdr job) |
| 156 | (rename-file-without-moaning old new)))))) |
| 157 | |
| 158 | (defun safely-reset (safe) |
| 159 | "Reset SAFE to its initial state." |
| 160 | (setf (safely-streams safe) nil) |
| 161 | (setf (safely-trail safe) nil)) |
| 162 | |
| 163 | (defun safely-bail (safe) |
| 164 | "Abort the operations in SAFE, unwinding all the things that have been |
| 165 | done. Streams are closed, new files are removed." |
| 166 | (dolist (stream (safely-streams safe)) |
| 167 | (close stream :abort t)) |
| 168 | (safely-unwind (safely-trail safe)) |
| 169 | (safely-reset safe)) |
| 170 | |
| 171 | #+sbcl |
| 172 | (defun unix-link (from to) |
| 173 | (sb-unix::int-syscall ("link" sb-alien:c-string sb-alien:c-string) |
| 174 | from to)) |
| 175 | |
| 176 | (defun safe-copy (file tag) |
| 177 | "Make a copy of the FILE. Return the new name." |
| 178 | |
| 179 | #+(or cmu sbcl) |
| 180 | ;; Use link(2) where available. |
| 181 | (generate-fresh-file-name file tag |
| 182 | (lambda (name) |
| 183 | (let ((from (native-namestring file |
| 184 | :as-file t)) |
| 185 | (to (native-namestring name |
| 186 | :as-file t))) |
| 187 | (and from to |
| 188 | (unix-link from to))))) |
| 189 | |
| 190 | #+clisp |
| 191 | (generate-fresh-file-name file tag |
| 192 | (lambda (name) |
| 193 | (posix:copy-file (namestring file) |
| 194 | (namestring name) |
| 195 | :method :hardlink |
| 196 | :if-exists nil))) |
| 197 | |
| 198 | #-(or cmu sbcl clisp) |
| 199 | ;; Otherwise just copy the file contents and hope for the best. |
| 200 | (with-open-file (input file :element-type :default) |
| 201 | (multiple-value-bind |
| 202 | (copy output) |
| 203 | (generate-fresh-file-name file tag |
| 204 | (lambda (name) |
| 205 | (open name |
| 206 | :direction :output |
| 207 | :if-exists nil |
| 208 | :element-type :default))) |
| 209 | (unwind-protect |
| 210 | (progn |
| 211 | (let ((buffer (make-array 8192 |
| 212 | :element-type (stream-element-type |
| 213 | input)))) |
| 214 | (loop |
| 215 | (let ((read (read-sequence buffer input))) |
| 216 | (when (plusp read) |
| 217 | (write-sequence buffer output :end read)) |
| 218 | (when (< read (length buffer)) |
| 219 | (return copy)))))) |
| 220 | (close output))))) |
| 221 | |
| 222 | (defun safely-commit (safe) |
| 223 | "Commit SAFE. The files deleted by safely-delete-file are deleted; the |
| 224 | files created by safely-open-output-stream are renamed over the old |
| 225 | versions, if any. If a problem occurs during this stage, everything is |
| 226 | rewound and no changes are made." |
| 227 | (let ((trail (safely-trail safe)) |
| 228 | (revert nil) |
| 229 | (cleanup nil)) |
| 230 | (unwind-protect |
| 231 | (progn |
| 232 | (dolist (stream (safely-streams safe)) |
| 233 | (close stream)) |
| 234 | (loop |
| 235 | (unless trail |
| 236 | (return)) |
| 237 | (let ((job (pop trail))) |
| 238 | (ecase (car job) |
| 239 | (:shunt (destructuring-bind (tag new file) job |
| 240 | (declare (ignore tag)) |
| 241 | (push `(:rmtmp ,new) revert) |
| 242 | (if (probe-file file) |
| 243 | (let ((old (safe-copy file "old"))) |
| 244 | (push `(:rmtmp ,old) cleanup) |
| 245 | (push `(:revert ,old ,file) revert)) |
| 246 | (push `(:rmtmp ,file) revert)) |
| 247 | (rename new file))) |
| 248 | (:delete (destructuring-bind (tag file) job |
| 249 | (declare (ignore tag)) |
| 250 | (let ((old (safe-copy file "delete"))) |
| 251 | (push `(:revert ,old ,file) revert) |
| 252 | (push `(:rmtmp ,old) cleanup) |
| 253 | (delete-file file))))))) |
| 254 | (setf revert nil)) |
| 255 | (safely-unwind trail) |
| 256 | (safely-unwind revert) |
| 257 | (safely-unwind cleanup) |
| 258 | (safely-reset safe)))) |
| 259 | |
| 260 | (defmacro safely ((safe &key) &body body) |
| 261 | "Do stuff within the BODY safely. If BODY completes without errors, the |
| 262 | SAFE is committed; otherwise it's bailed." |
| 263 | `(let ((,safe (make-safely))) |
| 264 | (unwind-protect |
| 265 | (progn |
| 266 | ,@body |
| 267 | (safely-commit ,safe) |
| 268 | (setf ,safe nil)) |
| 269 | (when ,safe |
| 270 | (safely-bail ,safe))))) |
| 271 | |
| 272 | (defmacro safely-writing ((stream file &rest open-args) &body body) |
| 273 | "Simple macro for writing a single file safely. STREAM is opened onto a |
| 274 | temporary file, and if BODY completes, it is renamed to FILE." |
| 275 | (with-gensyms safe |
| 276 | `(safely (,safe) |
| 277 | (let ((,stream (safely-open-output-stream ,safe ,file ,@open-args))) |
| 278 | ,@body)))) |
| 279 | |
| 280 | ;;;----- That's all, folks -------------------------------------------------- |