Commit | Line | Data |
---|---|---|
861345b4 | 1 | ;;; -*-lisp-*- |
2 | ;;; | |
861345b4 | 3 | ;;; Safely modify collections of files |
4 | ;;; | |
5 | ;;; (c) 2005 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This program is free software; you can redistribute it and/or modify | |
11 | ;;; it under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 2 of the License, or | |
13 | ;;; (at your option) any later version. | |
b2c12b4e | 14 | ;;; |
861345b4 | 15 | ;;; This program is distributed in the hope that it will be useful, |
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
b2c12b4e | 19 | ;;; |
861345b4 | 20 | ;;; You should have received a copy of the GNU General Public License |
21 | ;;; along with this program; if not, write to the Free Software Foundation, | |
22 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
23 | ||
0b3651e5 | 24 | (defpackage #:safely |
77f935da | 25 | (:use #:common-lisp #:mdw.base)) |
0b3651e5 | 26 | (in-package #:safely) |
861345b4 | 27 | |
d7d81997 MW |
28 | #+(or cmu sbcl) |
29 | (eval-when (:compile-toplevel :execute) | |
30 | (import #+cmu '(ext:unix-namestring unix:unix-link) | |
2d9f4fc0 MW |
31 | #+sbcl '(sb-ext:native-namestring))) |
32 | #+cmu | |
33 | (progn | |
34 | (declaim (inline unix-namestring)) | |
35 | (defun native-namestring (pathname &key as-file) | |
36 | (declare (ignore as-file)) | |
37 | (unix-namestring pathname nil))) | |
d7d81997 | 38 | |
77f935da MW |
39 | (export '(safely safelyp make-safely)) |
40 | (defstruct (safely (:predicate safelyp) (:constructor make-safely ())) | |
861345b4 | 41 | "Stores information about how to commit or undo safe writes." |
42 | (streams nil) | |
43 | (trail nil)) | |
5e04ac39 | 44 | |
77f935da | 45 | (export 'safely-close) |
861345b4 | 46 | (defun safely-close (safe stream) |
47 | "Make sure that STREAM is closed when SAFE is finished." | |
48 | (push stream (safely-streams safe))) | |
5e04ac39 | 49 | |
77f935da | 50 | (export 'safely-delete-file) |
861345b4 | 51 | (defun safely-delete-file (safe file) |
52 | "Delete FILE when SAFE is committed." | |
623291d2 MW |
53 | (push `(:delete ,file) (safely-trail safe))) |
54 | ||
55 | (defun generate-fresh-file-name (base tag &optional func) | |
56 | "Return a fresh file name constructed from BASE (a filespec) and TAG (some | |
57 | short descriptive string). The generated name has the same directory and | |
58 | type as the BASE name, but a different name. | |
59 | ||
60 | If FUNC is non-nil, then it is a function to call on the generated file | |
61 | name: generate-fresh-file-name runs in a loop, calling FUNC with generated | |
62 | file names until FUNC returns non-nil, at which point generate-fresh- | |
63 | file-name returns two values: the generated name, and the result of FUNC. | |
64 | generate-fresh-file-name catches errors of type file-error from FUNC, and | |
65 | just tries again with a new name. | |
66 | ||
67 | If FUNC is nil, it's treated the same as a function which always returns | |
68 | t. | |
69 | ||
70 | This is inspired by a similar facility in scsh." | |
71 | (let ((base (pathname base))) | |
72 | (dotimes (i 256 | |
73 | (error "Gave up trying to find a temporary ~A file for ~S." | |
74 | tag base)) | |
75 | (let* ((new (merge-pathnames | |
76 | (make-pathname | |
77 | :name (format nil "~A-~A-~X" | |
78 | (pathname-name base) | |
79 | tag | |
80 | (random most-positive-fixnum))) | |
81 | base)) | |
82 | (ret (and (not (probe-file new)) | |
83 | (if func | |
84 | (handler-case (funcall func new) | |
85 | (file-error (cond) | |
86 | (unless (pathname-match-p | |
87 | (file-error-pathname cond) | |
88 | new) | |
89 | (error cond)) | |
90 | nil)) | |
91 | t)))) | |
92 | (when ret | |
93 | (return (values new ret))))))) | |
5e04ac39 | 94 | |
77f935da | 95 | (export 'safely-open-output-stream) |
861345b4 | 96 | (defun safely-open-output-stream (safe file &rest open-args) |
97 | "Create an output stream which will be named FILE when SAFE is committed. | |
0ff9df03 | 98 | Other OPEN-ARGS are passed to open." |
623291d2 MW |
99 | (multiple-value-bind |
100 | (name stream) | |
101 | (generate-fresh-file-name file "new" | |
102 | (lambda (name) | |
103 | (apply #'open name | |
104 | :direction :output | |
105 | :if-exists nil | |
106 | open-args))) | |
861345b4 | 107 | (safely-close safe stream) |
623291d2 | 108 | (push `(:shunt ,name ,file) |
861345b4 | 109 | (safely-trail safe)) |
110 | stream)) | |
5e04ac39 | 111 | |
9224720f MW |
112 | #+clisp |
113 | (progn | |
114 | (ffi:def-call-out %rename (:name "rename") | |
115 | (:language :stdc) | |
4b53d23c | 116 | (:library "libc.so.6") |
9224720f MW |
117 | (:arguments (from ffi:c-string) |
118 | (to ffi:c-string)) | |
119 | (:return-type ffi:int))) | |
120 | ||
443fcfc4 MW |
121 | (declaim (inline rename)) |
122 | (defun rename (old new) | |
9224720f | 123 | #-clisp |
562ed2dd MW |
124 | (let ((target (make-pathname :directory '(:relative) |
125 | :defaults new))) | |
9224720f MW |
126 | (rename-file old target)) |
127 | ||
128 | #+clisp | |
129 | (let ((rc (%rename (namestring old) (namestring new)))) | |
130 | (when (= rc -1) | |
131 | (error "Failed to rename ~S to ~S: ~A" old new (posix:strerror))))) | |
443fcfc4 | 132 | |
861345b4 | 133 | (defun delete-file-without-moaning (file) |
134 | "Delete the FILE, ignoring errors." | |
623291d2 MW |
135 | (handler-case (delete-file file) |
136 | (file-error () nil))) | |
5e04ac39 | 137 | |
861345b4 | 138 | (defun rename-file-without-moaning (old new) |
139 | "Rename OLD to NEW, ignoring errors, and without doing any stupid name | |
0ff9df03 | 140 | mangling." |
443fcfc4 | 141 | (handler-case (rename old new) |
623291d2 | 142 | (file-error () nil))) |
5e04ac39 | 143 | |
861345b4 | 144 | (defun safely-unwind (trail) |
145 | "Roll back the TRAIL of operations." | |
146 | (dolist (job trail) | |
147 | (ecase (car job) | |
623291d2 MW |
148 | (:shunt (destructuring-bind (new file) (cdr job) |
149 | (declare (ignore file)) | |
861345b4 | 150 | (delete-file-without-moaning new))) |
151 | (:delete) | |
623291d2 | 152 | (:rmtmp (destructuring-bind (file) (cdr job) |
861345b4 | 153 | (delete-file-without-moaning file))) |
623291d2 | 154 | (:revert (destructuring-bind (old new) (cdr job) |
861345b4 | 155 | (rename-file-without-moaning old new)))))) |
5e04ac39 | 156 | |
861345b4 | 157 | (defun safely-reset (safe) |
158 | "Reset SAFE to its initial state." | |
159 | (setf (safely-streams safe) nil) | |
160 | (setf (safely-trail safe) nil)) | |
5e04ac39 | 161 | |
77f935da | 162 | (export 'safely-bail) |
861345b4 | 163 | (defun safely-bail (safe) |
164 | "Abort the operations in SAFE, unwinding all the things that have been | |
0ff9df03 | 165 | done. Streams are closed, new files are removed." |
861345b4 | 166 | (dolist (stream (safely-streams safe)) |
167 | (close stream :abort t)) | |
168 | (safely-unwind (safely-trail safe)) | |
169 | (safely-reset safe)) | |
5e04ac39 | 170 | |
d7d81997 MW |
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 | ||
623291d2 MW |
176 | (defun safe-copy (file tag) |
177 | "Make a copy of the FILE. Return the new name." | |
178 | ||
d7d81997 | 179 | #+(or cmu sbcl) |
623291d2 MW |
180 | ;; Use link(2) where available. |
181 | (generate-fresh-file-name file tag | |
182 | (lambda (name) | |
2d9f4fc0 MW |
183 | (let ((from (native-namestring file |
184 | :as-file t)) | |
185 | (to (native-namestring name | |
186 | :as-file t))) | |
623291d2 | 187 | (and from to |
d7d81997 | 188 | (unix-link from to))))) |
623291d2 | 189 | |
443fcfc4 MW |
190 | #+clisp |
191 | (generate-fresh-file-name file tag | |
192 | (lambda (name) | |
6a115035 MW |
193 | (posix:copy-file (namestring file) |
194 | (namestring name) | |
195 | :method :hardlink | |
196 | :if-exists nil))) | |
197 | ||
1a50efd8 | 198 | #-(or cmu sbcl clisp) |
623291d2 MW |
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))))) | |
b2c12b4e | 221 | |
77f935da | 222 | (export 'safely-commit) |
861345b4 | 223 | (defun safely-commit (safe) |
224 | "Commit SAFE. The files deleted by safely-delete-file are deleted; the | |
0ff9df03 MW |
225 | files created by safely-open-output-stream are renamed over the old |
226 | versions, if any. If a problem occurs during this stage, everything is | |
227 | rewound and no changes are made." | |
861345b4 | 228 | (let ((trail (safely-trail safe)) |
229 | (revert nil) | |
230 | (cleanup nil)) | |
231 | (unwind-protect | |
232 | (progn | |
233 | (dolist (stream (safely-streams safe)) | |
234 | (close stream)) | |
235 | (loop | |
236 | (unless trail | |
237 | (return)) | |
6e1633e7 MW |
238 | (let ((job (pop trail))) |
239 | (ecase (car job) | |
240 | (:shunt (destructuring-bind (tag new file) job | |
241 | (declare (ignore tag)) | |
242 | (push `(:rmtmp ,new) revert) | |
243 | (if (probe-file file) | |
244 | (let ((old (safe-copy file "old"))) | |
245 | (push `(:rmtmp ,old) cleanup) | |
246 | (push `(:revert ,old ,file) revert)) | |
247 | (push `(:rmtmp ,file) revert)) | |
248 | (rename new file))) | |
249 | (:delete (destructuring-bind (tag file) job | |
250 | (declare (ignore tag)) | |
251 | (let ((old (safe-copy file "delete"))) | |
252 | (push `(:revert ,old ,file) revert) | |
253 | (push `(:rmtmp ,old) cleanup) | |
254 | (delete-file file))))))) | |
861345b4 | 255 | (setf revert nil)) |
256 | (safely-unwind trail) | |
257 | (safely-unwind revert) | |
258 | (safely-unwind cleanup) | |
259 | (safely-reset safe)))) | |
5e04ac39 | 260 | |
77f935da | 261 | ;; The symbol `safely' is already exported. |
861345b4 | 262 | (defmacro safely ((safe &key) &body body) |
263 | "Do stuff within the BODY safely. If BODY completes without errors, the | |
0ff9df03 | 264 | SAFE is committed; otherwise it's bailed." |
861345b4 | 265 | `(let ((,safe (make-safely))) |
266 | (unwind-protect | |
267 | (progn | |
268 | ,@body | |
269 | (safely-commit ,safe) | |
270 | (setf ,safe nil)) | |
271 | (when ,safe | |
272 | (safely-bail ,safe))))) | |
5e04ac39 | 273 | |
77f935da | 274 | (export 'safely-writing) |
861345b4 | 275 | (defmacro safely-writing ((stream file &rest open-args) &body body) |
276 | "Simple macro for writing a single file safely. STREAM is opened onto a | |
0ff9df03 | 277 | temporary file, and if BODY completes, it is renamed to FILE." |
861345b4 | 278 | (with-gensyms safe |
279 | `(safely (,safe) | |
7413889a | 280 | (let ((,stream (safely-open-output-stream ,safe ,file ,@open-args))) |
861345b4 | 281 | ,@body)))) |
282 | ||
283 | ;;;----- That's all, folks -------------------------------------------------- |