X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/5e04ac396871d9b15a4cbcdb7de9084b650176f0..813da880d2d77f04ea623f426d543d298528f967:/safely.lisp diff --git a/safely.lisp b/safely.lisp index 5eddef3..9b39518 100644 --- a/safely.lisp +++ b/safely.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; Safely modify collections of files ;;; ;;; (c) 2005 Straylight/Edgeware @@ -13,83 +11,147 @@ ;;; 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) - (:export #:safely #:safely-close #:safely-delete-file - #:safely-open-output-stream #:safely-bail #:safely-commit - #:safely-writing)) -(in-package #:mdw.safely) +(defpackage #:safely + (:use #:common-lisp #:mdw.base)) +(in-package #:safely) + +#+(or cmu sbcl) +(eval-when (:compile-toplevel :execute) + (import #+cmu '(ext:unix-namestring unix:unix-link) + #+sbcl '(sb-ext:native-namestring))) +#+cmu +(progn + (declaim (inline unix-namestring)) + (defun native-namestring (pathname &key as-file) + (declare (ignore as-file)) + (unix-namestring pathname nil))) -(defstruct (safely (:predicate safelyp)) +(export '(safely safelyp make-safely)) +(defstruct (safely (:predicate safelyp) (:constructor make-safely ())) "Stores information about how to commit or undo safe writes." (streams nil) (trail nil)) +(export 'safely-close) (defun safely-close (safe stream) "Make sure that STREAM is closed when SAFE is finished." (push stream (safely-streams safe))) +(export 'safely-delete-file) (defun safely-delete-file (safe file) "Delete FILE when SAFE is committed." - (push `(:delete ,file ,(fresh-file-name file "del")) (safely-trail safe))) + (push `(:delete ,file) (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))) +(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))))))) + +(export 'safely-open-output-stream) (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)) +#+clisp +(progn + (ffi:def-call-out %rename (:name "rename") + (:language :stdc) + (:library "libc.so.6") + (:arguments (from ffi:c-string) + (to ffi:c-string)) + (:return-type ffi:int))) + +(declaim (inline rename)) +(defun rename (old new) + #-clisp + (let ((target (make-pathname :directory '(:relative) + :defaults new))) + (rename-file old target)) + + #+clisp + (let ((rc (%rename (namestring old) (namestring new)))) + (when (= rc -1) + (error "Failed to rename ~S to ~S: ~A" old new (posix:strerror))))) + (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 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) @@ -97,19 +159,72 @@ mangling." (setf (safely-streams safe) nil) (setf (safely-trail safe) nil)) +(export 'safely-bail) (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 (native-namestring file + :as-file t)) + (to (native-namestring name + :as-file t))) + (and from to + (unix-link from to))))) + + #+clisp + (generate-fresh-file-name file tag + (lambda (name) + (posix:copy-file (namestring file) + (namestring name) + :method :hardlink + :if-exists nil))) + + #-(or cmu sbcl clisp) + ;; 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))))) + +(export 'safely-commit) (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)) @@ -120,32 +235,33 @@ changes are made." (loop (unless trail (return)) - (let ((job (pop trail))) - (ecase (car job) - (:shunt (destructuring-bind (tag new file old) job - (declare (ignore tag)) - (push `(:rmtmp ,old) cleanup) - (push `(:rmtmp ,new) revert) - (if (probe-file file) - (progn - (copy-file file old) - (push `(:revert ,old ,file) revert)) - (push `(:rmtmp ,file) revert)) - (unix-try rename new file))) - (:delete (destructuring-bind (tag file old) job - (declare (ignore tag)) + (let ((job (pop trail))) + (ecase (car job) + (:shunt (destructuring-bind (tag new file) job + (declare (ignore tag)) + (push `(:rmtmp ,new) revert) + (if (probe-file file) + (let ((old (safe-copy file "old"))) + (push `(:rmtmp ,old) cleanup) + (push `(:revert ,old ,file) revert)) + (push `(:rmtmp ,file) revert)) + (rename new file))) + (:delete (destructuring-bind (tag file) job + (declare (ignore tag)) + (let ((old (safe-copy file "delete"))) (push `(:revert ,old ,file) revert) - (unix-try rename file old) - (push `(:rmtmp old) cleanup)))))) + (push `(:rmtmp ,old) cleanup) + (delete-file file))))))) (setf revert nil)) (safely-unwind trail) (safely-unwind revert) (safely-unwind cleanup) (safely-reset safe)))) +;; The symbol `safely' is already exported. (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 @@ -155,13 +271,13 @@ SAFE is committed; otherwise it's bailed." (when ,safe (safely-bail ,safe))))) +(export 'safely-writing) (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 - ,safe ,file ,open-args))) + (let ((,stream (safely-open-output-stream ,safe ,file ,@open-args))) ,@body)))) ;;;----- That's all, folks --------------------------------------------------