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 | |
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)) |
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." |
70 | (when (probe-file file) |
ad8995ca |
71 | (sys-unlink file))) |
5e04ac39 |
72 | |
861345b4 |
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) |
ad8995ca |
77 | (sys-rename old new))) |
5e04ac39 |
78 | |
861345b4 |
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)))))) |
5e04ac39 |
94 | |
861345b4 |
95 | (defun safely-reset (safe) |
96 | "Reset SAFE to its initial state." |
97 | (setf (safely-streams safe) nil) |
98 | (setf (safely-trail safe) nil)) |
5e04ac39 |
99 | |
861345b4 |
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)) |
5e04ac39 |
107 | |
861345b4 |
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)) |
ad8995ca |
134 | (sys-rename new file))) |
861345b4 |
135 | (:delete (destructuring-bind (tag file old) job |
136 | (declare (ignore tag)) |
137 | (push `(:revert ,old ,file) revert) |
ad8995ca |
138 | (sys-rename file old) |
861345b4 |
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)))) |
5e04ac39 |
145 | |
861345b4 |
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))))) |
5e04ac39 |
157 | |
861345b4 |
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 -------------------------------------------------- |