X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/2d8bac2c972c9fc294f48df7b6afc34fab744608..5f61c96135dd8b0e795f6e1e5d96708347fc8f5e:/safely.lisp diff --git a/safely.lisp b/safely.lisp index c78492a..b5d7ff8 100644 --- a/safely.lisp +++ b/safely.lisp @@ -13,22 +13,27 @@ ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. -;;; +;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. -;;; +;;; ;;; You should have received a copy of the GNU General Public License ;;; 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) + +#+(or cmu sbcl) +(eval-when (:compile-toplevel :execute) + (import #+cmu '(ext:unix-namestring unix:unix-link) + #+sbcl '(sb-int:unix-namestring))) (defstruct (safely (:predicate safelyp)) "Stores information about how to commit or undo safe writes." @@ -41,57 +46,86 @@ (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." - (with-errno-handlers () - (sys-unlink file) - (ENOENT nil))) + (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." - (with-errno-handlers () - (sys-rename old new) - (ENOENT nil))) + 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) @@ -101,17 +135,58 @@ mangling." (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)) +#+sbcl +(defun unix-link (from to) + (sb-unix::int-syscall ("link" sb-alien:c-string sb-alien:c-string) + from to)) + +(defun safe-copy (file tag) + "Make a copy of the FILE. Return the new name." + + #+(or cmu sbcl) + ;; Use link(2) where available. + (generate-fresh-file-name file tag + (lambda (name) + (let ((from (unix-namestring file t)) + (to (unix-namestring name nil))) + (and from to + (unix-link from to))))) + + #-(or cmu sbcl) + ;; 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)) @@ -124,21 +199,21 @@ 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)) - (sys-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) - (sys-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) @@ -147,7 +222,7 @@ changes are made." (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 @@ -159,7 +234,7 @@ SAFE is committed; otherwise it's bailed." (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