From: Mark Wooding Date: Thu, 11 May 2006 18:41:58 +0000 (+0100) Subject: safely: Temporary file name changes. X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/commitdiff_plain/623291d25eb6f31558f252f037997549171b4d24 safely: Temporary file name changes. * Use CL pathname magic to mess only with the name component of paths rather than putting extensions on the end, which seems to confuse CMU CL. * Use a Scsh-like fresh-name generator where it matters, rather than hoping (in the case of move-aside names). This means generating old names later on in the process, but that seems OK. * Do the file copy in plain Lisp using read/write-sequence rather than Unix hacking. There's a hack here for CMU CL to use link(2) for efficiency's sake, but it's not strictly necessary. This means that the whole package is, in fact, standard Common Lisp. Yay. --- diff --git a/safely.lisp b/safely.lisp index 60dd683..44a707e 100644 --- a/safely.lisp +++ b/safely.lisp @@ -24,7 +24,7 @@ ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (defpackage #:safely - (:use #:common-lisp #:mdw.base #:mdw.unix) + (:use #:common-lisp #:mdw.base) (:export #:safely #:safely-close #:safely-delete-file #:safely-open-output-stream #:safely-bail #:safely-commit #:safely-writing)) @@ -41,57 +41,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))) + (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))) + (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) @@ -107,6 +136,42 @@ (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 @@ -124,21 +189,21 @@ (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)