;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Safely modify collections of files
;;;
;;; (c) 2005 Straylight/Edgeware
;;; 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)))
(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."
(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)
(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)
(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."
(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
(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
(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."
(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 --------------------------------------------------
~mdw / lisp / blobdiff