Commit | Line | Data |
---|---|---|
861345b4 | 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 | ||
0b3651e5 | 26 | (defpackage #:safely |
861345b4 | 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)) | |
0b3651e5 | 31 | (in-package #:safely) |
861345b4 | 32 | |
33 | (defstruct (safely (:predicate safelyp)) | |
34 | "Stores information about how to commit or undo safe writes." | |
35 | (streams nil) | |
36 | (trail nil)) | |
5e04ac39 | 37 | |
861345b4 | 38 | (defun safely-close (safe stream) |
39 | "Make sure that STREAM is closed when SAFE is finished." | |
40 | (push stream (safely-streams safe))) | |
5e04ac39 | 41 | |
861345b4 | 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))) | |
5e04ac39 | 45 | |
861345b4 | 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))) | |
5e04ac39 | 53 | |
861345b4 | 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)) | |
5e04ac39 | 67 | |
861345b4 | 68 | (defun delete-file-without-moaning (file) |
69 | "Delete the FILE, ignoring errors." | |
2d8bac2c MW |
70 | (with-errno-handlers () |
71 | (sys-unlink file) | |
72 | (ENOENT nil))) | |
5e04ac39 | 73 | |
861345b4 | 74 | (defun rename-file-without-moaning (old new) |
75 | "Rename OLD to NEW, ignoring errors, and without doing any stupid name | |
76 | mangling." | |
2d8bac2c MW |
77 | (with-errno-handlers () |
78 | (sys-rename old new) | |
79 | (ENOENT nil))) | |
5e04ac39 | 80 | |
861345b4 | 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)))))) | |
5e04ac39 | 96 | |
861345b4 | 97 | (defun safely-reset (safe) |
98 | "Reset SAFE to its initial state." | |
99 | (setf (safely-streams safe) nil) | |
100 | (setf (safely-trail safe) nil)) | |
5e04ac39 | 101 | |
861345b4 | 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)) | |
5e04ac39 | 109 | |
861345b4 | 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)) | |
ad8995ca | 136 | (sys-rename new file))) |
861345b4 | 137 | (:delete (destructuring-bind (tag file old) job |
138 | (declare (ignore tag)) | |
139 | (push `(:revert ,old ,file) revert) | |
ad8995ca | 140 | (sys-rename file old) |
861345b4 | 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)))) | |
5e04ac39 | 147 | |
861345b4 | 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))))) | |
5e04ac39 | 159 | |
861345b4 | 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 -------------------------------------------------- |