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)) |
37 | (defun safely-close (safe stream) |
38 | "Make sure that STREAM is closed when SAFE is finished." |
39 | (push stream (safely-streams safe))) |
40 | (defun safely-delete-file (safe file) |
41 | "Delete FILE when SAFE is committed." |
42 | (push `(:delete ,file ,(fresh-file-name file "del")) (safely-trail safe))) |
43 | (defun fresh-file-name (base tag) |
44 | "Return a fresh file name constructed from BASE and TAG in the current |
45 | directory. Do not assume that this filename will be good by the time you try |
46 | to create the file." |
47 | (let ((name (format nil "~A.~A-~X" |
48 | base tag (random most-positive-fixnum)))) |
49 | (if (probe-file name) (fresh-file-name base tag) name))) |
50 | (defun safely-open-output-stream (safe file &rest open-args) |
51 | "Create an output stream which will be named FILE when SAFE is committed. |
52 | Other OPEN-ARGS are passed to open." |
53 | (let* ((new (fresh-file-name file "new")) |
54 | (stream (apply #'open |
55 | new |
56 | :direction :output |
57 | :if-exists :error |
58 | open-args))) |
59 | (safely-close safe stream) |
60 | (push `(:shunt ,new ,file ,(fresh-file-name file "old")) |
61 | (safely-trail safe)) |
62 | stream)) |
63 | (defun delete-file-without-moaning (file) |
64 | "Delete the FILE, ignoring errors." |
65 | (when (probe-file file) |
66 | (unix-try unlink file))) |
67 | (defun rename-file-without-moaning (old new) |
68 | "Rename OLD to NEW, ignoring errors, and without doing any stupid name |
69 | mangling." |
70 | (when (probe-file old) |
71 | (unix-try rename old new))) |
72 | (defun safely-unwind (trail) |
73 | "Roll back the TRAIL of operations." |
74 | (dolist (job trail) |
75 | (ecase (car job) |
76 | (:shunt (destructuring-bind (tag new file old) job |
77 | (declare (ignore tag file)) |
78 | (delete-file-without-moaning old) |
79 | (delete-file-without-moaning new))) |
80 | (:delete) |
81 | (:rmtmp (destructuring-bind (tag file) job |
82 | (declare (ignore tag)) |
83 | (delete-file-without-moaning file))) |
84 | (:revert (destructuring-bind (tag old new) job |
85 | (declare (ignore tag)) |
86 | (rename-file-without-moaning old new)))))) |
87 | (defun safely-reset (safe) |
88 | "Reset SAFE to its initial state." |
89 | (setf (safely-streams safe) nil) |
90 | (setf (safely-trail safe) nil)) |
91 | (defun safely-bail (safe) |
92 | "Abort the operations in SAFE, unwinding all the things that have been |
93 | done. Streams are closed, new files are removed." |
94 | (dolist (stream (safely-streams safe)) |
95 | (close stream :abort t)) |
96 | (safely-unwind (safely-trail safe)) |
97 | (safely-reset safe)) |
98 | (defun safely-commit (safe) |
99 | "Commit SAFE. The files deleted by safely-delete-file are deleted; the |
100 | files created by safely-open-output-stream are renamed over the old versions, |
101 | if any. If a problem occurs during this stage, everything is rewound and no |
102 | changes are made." |
103 | (let ((trail (safely-trail safe)) |
104 | (revert nil) |
105 | (cleanup nil)) |
106 | (unwind-protect |
107 | (progn |
108 | (dolist (stream (safely-streams safe)) |
109 | (close stream)) |
110 | (loop |
111 | (unless trail |
112 | (return)) |
113 | (let ((job (pop trail))) |
114 | (ecase (car job) |
115 | (:shunt (destructuring-bind (tag new file old) job |
116 | (declare (ignore tag)) |
117 | (push `(:rmtmp ,old) cleanup) |
118 | (push `(:rmtmp ,new) revert) |
119 | (if (probe-file file) |
120 | (progn |
121 | (copy-file file old) |
122 | (push `(:revert ,old ,file) revert)) |
123 | (push `(:rmtmp ,file) revert)) |
124 | (unix-try rename new file))) |
125 | (:delete (destructuring-bind (tag file old) job |
126 | (declare (ignore tag)) |
127 | (push `(:revert ,old ,file) revert) |
128 | (unix-try rename file old) |
129 | (push `(:rmtmp old) cleanup)))))) |
130 | (setf revert nil)) |
131 | (safely-unwind trail) |
132 | (safely-unwind revert) |
133 | (safely-unwind cleanup) |
134 | (safely-reset safe)))) |
135 | (defmacro safely ((safe &key) &body body) |
136 | "Do stuff within the BODY safely. If BODY completes without errors, the |
137 | SAFE is committed; otherwise it's bailed." |
138 | `(let ((,safe (make-safely))) |
139 | (unwind-protect |
140 | (progn |
141 | ,@body |
142 | (safely-commit ,safe) |
143 | (setf ,safe nil)) |
144 | (when ,safe |
145 | (safely-bail ,safe))))) |
146 | (defmacro safely-writing ((stream file &rest open-args) &body body) |
147 | "Simple macro for writing a single file safely. STREAM is opened onto a |
148 | temporary file, and if BODY completes, it is renamed to FILE." |
149 | (with-gensyms safe |
150 | `(safely (,safe) |
151 | (let ((,stream (apply #'safely-open-output-stream |
152 | ,safe ,file ,open-args))) |
153 | ,@body)))) |
154 | |
155 | ;;;----- That's all, folks -------------------------------------------------- |