X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/861345b43569790e39df152c6b495b14e7dab360..67b41ed338b6050f40bf9de24804502e96f84104:/safely.lisp diff --git a/safely.lisp b/safely.lisp index 6153060..44a707e 100644 --- a/safely.lisp +++ b/safely.lisp @@ -23,83 +23,160 @@ ;;; along with this program; if not, write to the Free Software Foundation, ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -(defpackage #:mdw.safely - (:use #:common-lisp #:mdw.base #:mdw.unix) +(defpackage #:safely + (:use #:common-lisp #:mdw.base) (:export #:safely #:safely-close #:safely-delete-file #:safely-open-output-stream #:safely-bail #:safely-commit #:safely-writing)) -(in-package #:mdw.safely) +(in-package #:safely) (defstruct (safely (:predicate safelyp)) "Stores information about how to commit or undo safe writes." (streams nil) (trail nil)) + (defun safely-close (safe stream) "Make sure that STREAM is closed when SAFE is finished." (push stream (safely-streams safe))) + (defun safely-delete-file (safe file) "Delete FILE when SAFE is committed." - (push `(:delete ,file ,(fresh-file-name file "del")) (safely-trail safe))) -(defun fresh-file-name (base tag) - "Return a fresh file name constructed from BASE and TAG in the current -directory. Do not assume that this filename will be good by the time you try -to create the file." - (let ((name (format nil "~A.~A-~X" - base tag (random most-positive-fixnum)))) - (if (probe-file name) (fresh-file-name base tag) name))) + (push `(:delete ,file) (safely-trail safe))) + +(defun generate-fresh-file-name (base tag &optional func) + "Return a fresh file name constructed from BASE (a filespec) and TAG (some + short descriptive string). The generated name has the same directory and + type as the BASE name, but a different name. + + If FUNC is non-nil, then it is a function to call on the generated file + name: generate-fresh-file-name runs in a loop, calling FUNC with generated + file names until FUNC returns non-nil, at which point generate-fresh- + file-name returns two values: the generated name, and the result of FUNC. + generate-fresh-file-name catches errors of type file-error from FUNC, and + just tries again with a new name. + + If FUNC is nil, it's treated the same as a function which always returns + t. + + This is inspired by a similar facility in scsh." + (let ((base (pathname base))) + (dotimes (i 256 + (error "Gave up trying to find a temporary ~A file for ~S." + tag base)) + (let* ((new (merge-pathnames + (make-pathname + :name (format nil "~A-~A-~X" + (pathname-name base) + tag + (random most-positive-fixnum))) + base)) + (ret (and (not (probe-file new)) + (if func + (handler-case (funcall func new) + (file-error (cond) + (unless (pathname-match-p + (file-error-pathname cond) + new) + (error cond)) + nil)) + t)))) + (when ret + (return (values new ret))))))) + (defun safely-open-output-stream (safe file &rest open-args) "Create an output stream which will be named FILE when SAFE is committed. -Other OPEN-ARGS are passed to open." - (let* ((new (fresh-file-name file "new")) - (stream (apply #'open - new - :direction :output - :if-exists :error - open-args))) + Other OPEN-ARGS are passed to open." + (multiple-value-bind + (name stream) + (generate-fresh-file-name file "new" + (lambda (name) + (apply #'open name + :direction :output + :if-exists nil + open-args))) (safely-close safe stream) - (push `(:shunt ,new ,file ,(fresh-file-name file "old")) + (push `(:shunt ,name ,file) (safely-trail safe)) stream)) + (defun delete-file-without-moaning (file) "Delete the FILE, ignoring errors." - (when (probe-file file) - (unix-try unlink file))) + (handler-case (delete-file file) + (file-error () nil))) + (defun rename-file-without-moaning (old new) "Rename OLD to NEW, ignoring errors, and without doing any stupid name -mangling." - (when (probe-file old) - (unix-try rename old new))) + mangling." + (handler-case (rename-file old new) + (file-error () nil))) + (defun safely-unwind (trail) "Roll back the TRAIL of operations." (dolist (job trail) (ecase (car job) - (:shunt (destructuring-bind (tag new file old) job - (declare (ignore tag file)) - (delete-file-without-moaning old) + (:shunt (destructuring-bind (new file) (cdr job) + (declare (ignore file)) (delete-file-without-moaning new))) (:delete) - (:rmtmp (destructuring-bind (tag file) job - (declare (ignore tag)) + (:rmtmp (destructuring-bind (file) (cdr job) (delete-file-without-moaning file))) - (:revert (destructuring-bind (tag old new) job - (declare (ignore tag)) + (:revert (destructuring-bind (old new) (cdr job) (rename-file-without-moaning old new)))))) + (defun safely-reset (safe) "Reset SAFE to its initial state." (setf (safely-streams safe) nil) (setf (safely-trail safe) nil)) + (defun safely-bail (safe) "Abort the operations in SAFE, unwinding all the things that have been -done. Streams are closed, new files are removed." + done. Streams are closed, new files are removed." (dolist (stream (safely-streams safe)) (close stream :abort t)) (safely-unwind (safely-trail safe)) (safely-reset safe)) + +(defun safe-copy (file tag) + "Make a copy of the FILE. Return the new name." + + #+cmu + ;; Use link(2) where available. + (generate-fresh-file-name file tag + (lambda (name) + (let ((from (ext:unix-namestring file t)) + (to (ext:unix-namestring name nil))) + (and from to + (unix:unix-link from to))))) + + #-cmu + ;; Otherwise just copy the file contents and hope for the best. + (with-open-file (input file :element-type :default) + (multiple-value-bind + (copy output) + (generate-fresh-file-name file tag + (lambda (name) + (open name + :direction :output + :if-exists nil + :element-type :default))) + (unwind-protect + (progn + (let ((buffer (make-array 8192 + :element-type (stream-element-type + input)))) + (loop + (let ((read (read-sequence buffer input))) + (when (plusp read) + (write-sequence buffer output :end read)) + (when (< read (length buffer)) + (return copy)))))) + (close output))))) + (defun safely-commit (safe) "Commit SAFE. The files deleted by safely-delete-file are deleted; the -files created by safely-open-output-stream are renamed over the old versions, -if any. If a problem occurs during this stage, everything is rewound and no -changes are made." + files created by safely-open-output-stream are renamed over the old + versions, if any. If a problem occurs during this stage, everything is + rewound and no changes are made." (let ((trail (safely-trail safe)) (revert nil) (cleanup nil)) @@ -112,29 +189,30 @@ changes are made." (return)) (let ((job (pop trail))) (ecase (car job) - (:shunt (destructuring-bind (tag new file old) job + (:shunt (destructuring-bind (tag new file) job (declare (ignore tag)) - (push `(:rmtmp ,old) cleanup) (push `(:rmtmp ,new) revert) (if (probe-file file) - (progn - (copy-file file old) + (let ((old (safe-copy file "old"))) + (push `(:rmtmp ,old) cleanup) (push `(:revert ,old ,file) revert)) (push `(:rmtmp ,file) revert)) - (unix-try rename new file))) - (:delete (destructuring-bind (tag file old) job + (rename-file new file))) + (:delete (destructuring-bind (tag file) job (declare (ignore tag)) - (push `(:revert ,old ,file) revert) - (unix-try rename file old) - (push `(:rmtmp old) cleanup)))))) + (let ((old (safe-copy file "delete"))) + (push `(:revert ,old ,file) revert) + (push `(:rmtmp ,old) cleanup) + (delete-file file))))))) (setf revert nil)) (safely-unwind trail) (safely-unwind revert) (safely-unwind cleanup) (safely-reset safe)))) + (defmacro safely ((safe &key) &body body) "Do stuff within the BODY safely. If BODY completes without errors, the -SAFE is committed; otherwise it's bailed." + SAFE is committed; otherwise it's bailed." `(let ((,safe (make-safely))) (unwind-protect (progn @@ -143,9 +221,10 @@ SAFE is committed; otherwise it's bailed." (setf ,safe nil)) (when ,safe (safely-bail ,safe))))) + (defmacro safely-writing ((stream file &rest open-args) &body body) "Simple macro for writing a single file safely. STREAM is opened onto a -temporary file, and if BODY completes, it is renamed to FILE." + temporary file, and if BODY completes, it is renamed to FILE." (with-gensyms safe `(safely (,safe) (let ((,stream (apply #'safely-open-output-stream