5 ;;; Safely modify collections of files
7 ;;; (c) 2005 Straylight/Edgeware
10 ;;;----- Licensing notice ---------------------------------------------------
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.
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.
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.
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
33 (defstruct (safely (:predicate safelyp))
34 "Stores information about how to commit or undo safe writes."
38 (defun safely-close (safe stream)
39 "Make sure that STREAM is closed when SAFE is finished."
40 (push stream (safely-streams safe)))
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)))
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
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)))
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"))
63 (safely-close safe stream)
64 (push `(:shunt ,new ,file ,(fresh-file-name file "old"))
68 (defun delete-file-without-moaning (file)
69 "Delete the FILE, ignoring errors."
70 (with-errno-handlers ()
74 (defun rename-file-without-moaning (old new)
75 "Rename OLD to NEW, ignoring errors, and without doing any stupid name
77 (with-errno-handlers ()
81 (defun safely-unwind (trail)
82 "Roll back the TRAIL of operations."
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)))
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))))))
97 (defun safely-reset (safe)
98 "Reset SAFE to its initial state."
99 (setf (safely-streams safe) nil)
100 (setf (safely-trail safe) nil))
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))
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
115 (let ((trail (safely-trail safe))
120 (dolist (stream (safely-streams safe))
125 (let ((job (pop trail)))
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)
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))))))
143 (safely-unwind trail)
144 (safely-unwind revert)
145 (safely-unwind cleanup)
146 (safely-reset safe))))
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)))
155 (safely-commit ,safe)
158 (safely-bail ,safe)))))
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."
165 (let ((,stream (apply #'safely-open-output-stream
166 ,safe ,file ,open-args)))
169 ;;;----- That's all, folks --------------------------------------------------