X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/623291d25eb6f31558f252f037997549171b4d24..813da880d2d77f04ea623f426d543d298528f967:/safely.lisp diff --git a/safely.lisp b/safely.lisp index 44a707e..9b39518 100644 --- a/safely.lisp +++ b/safely.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; Safely modify collections of files ;;; ;;; (c) 2005 Straylight/Edgeware @@ -13,32 +11,43 @@ ;;; 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 #:safely - (:use #:common-lisp #:mdw.base) - (:export #:safely #:safely-close #:safely-delete-file - #:safely-open-output-stream #:safely-bail #:safely-commit - #:safely-writing)) + (:use #:common-lisp #:mdw.base)) (in-package #:safely) -(defstruct (safely (:predicate safelyp)) +#+(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))) + +(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) (safely-trail safe))) @@ -83,6 +92,7 @@ (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." @@ -99,6 +109,27 @@ (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." (handler-case (delete-file file) @@ -107,7 +138,7 @@ (defun rename-file-without-moaning (old new) "Rename OLD to NEW, ignoring errors, and without doing any stupid name mangling." - (handler-case (rename-file old new) + (handler-case (rename old new) (file-error () nil))) (defun safely-unwind (trail) @@ -128,6 +159,7 @@ (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." @@ -136,19 +168,34 @@ (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." - #+cmu + #+(or cmu sbcl) ;; 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))) + (let ((from (native-namestring file + :as-file t)) + (to (native-namestring name + :as-file t))) (and from to - (unix:unix-link 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))) - #-cmu + #-(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 @@ -171,7 +218,8 @@ (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 @@ -187,29 +235,30 @@ (loop (unless trail (return)) - (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-file new file))) - (:delete (destructuring-bind (tag file) job - (declare (ignore tag)) - (let ((old (safe-copy file "delete"))) - (push `(:revert ,old ,file) revert) - (push `(:rmtmp ,old) cleanup) - (delete-file file))))))) + (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) + (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." @@ -222,13 +271,13 @@ (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." (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 --------------------------------------------------