mop: Use CMUCL's `mop' package instead of `pcl'.

[lisp] / safely.lisp

;;; -*-lisp-*-
;;;
;;; $Id$
;;;
;;; Safely modify collections of files
;;;
;;; (c) 2005 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; 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 #:mdw.unix)
  (:export #:safely #:safely-close #:safely-delete-file
	   #:safely-open-output-stream #:safely-bail #:safely-commit
	   #:safely-writing))
(in-package #:safely)

(defstruct (safely (:predicate safelyp))
  "Stores information about how to commit or undo safe writes."
  (streams nil)
  (trail nil))

(defun safely-close (safe stream)
  "Make sure that STREAM is closed when SAFE is finished."
  (push stream (safely-streams safe)))

(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)))

(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)))
    (safely-close safe stream)
    (push `(:shunt ,new ,file ,(fresh-file-name file "old"))
	  (safely-trail safe))
    stream))

(defun delete-file-without-moaning (file)
  "Delete the FILE, ignoring errors."
  (with-errno-handlers ()
      (sys-unlink file)
    (ENOENT 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)))

(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)
		(delete-file-without-moaning new)))
      (:delete)
      (:rmtmp (destructuring-bind (tag file) job
		(declare (ignore tag))
		(delete-file-without-moaning file)))
      (:revert (destructuring-bind (tag old new) job
		 (declare (ignore tag))
		 (rename-file-without-moaning old new))))))

(defun safely-reset (safe)
  "Reset SAFE to its initial state."
  (setf (safely-streams safe) nil)
  (setf (safely-trail safe) nil))

(defun safely-bail (safe)
  "Abort the operations in SAFE, unwinding all the things that have been
   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))

(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."
  (let ((trail (safely-trail safe))
	(revert nil)
	(cleanup nil))
    (unwind-protect
	(progn
	  (dolist (stream (safely-streams safe))
	    (close stream))
	  (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))
			    (sys-rename new file)))
		  (:delete (destructuring-bind (tag file old) job
			     (declare (ignore tag))
			     (push `(:revert ,old ,file) revert)
			     (sys-rename file old)
			     (push `(:rmtmp old) cleanup))))))
	  (setf revert nil))
      (safely-unwind trail)
      (safely-unwind revert)
      (safely-unwind cleanup)
      (safely-reset safe))))

(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."
  `(let ((,safe (make-safely)))
     (unwind-protect
	 (progn
	   ,@body
	   (safely-commit ,safe)
	   (setf ,safe nil))
       (when ,safe
	 (safely-bail ,safe)))))

(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)))
	 ,@body))))

;;;----- That's all, folks --------------------------------------------------