[climacs-cvs] CVS climacs

[dmurray]

Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv6143

Modified Files:
	pane.lisp packages.lisp file-commands.lisp 
Log Message:
Changed backup behaviour. Now makes emacs-style versioned backups
(foo.lisp~42~) once per session. Also checks to see if the file
has changed on disk when saving and reverting.


--- /project/climacs/cvsroot/climacs/pane.lisp	2006/04/23 19:37:58	1.37
+++ /project/climacs/cvsroot/climacs/pane.lisp	2006/05/06 06:27:14	1.38
@@ -227,8 +227,10 @@
 
 (defparameter +climacs-textual-view+ (make-instance 'climacs-textual-view))
 
-(defclass filepath-mixin ()
-  ((filepath :initform nil :accessor filepath)))
+(defclass file-mixin ()
+  ((filepath :initform nil :accessor filepath)
+   (file-saved-p :initform nil :accessor file-saved-p)
+   (file-write-time :initform nil :accessor file-write-time)))
 
 ;(defgeneric indent-tabs-mode (climacs-buffer))
 
@@ -238,7 +240,7 @@
 (defclass extended-binseq2-buffer (read-only-mixin binseq2-buffer p-undo-mixin abbrev-mixin) ()
   (:documentation "Extensions accessible via marks."))
 
-(defclass climacs-buffer (delegating-buffer filepath-mixin name-mixin)
+(defclass climacs-buffer (delegating-buffer file-mixin name-mixin)
   ((needs-saving :initform nil :accessor needs-saving)
    (syntax :accessor syntax)
    (point :initform nil :initarg :point :accessor point)
--- /project/climacs/cvsroot/climacs/packages.lisp	2006/05/01 18:36:41	1.91
+++ /project/climacs/cvsroot/climacs/packages.lisp	2006/05/06 06:27:14	1.92
@@ -145,7 +145,8 @@
 (defpackage :climacs-pane
   (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev
 	:climacs-syntax :flexichain :undo)
-  (:export #:climacs-buffer #:needs-saving #:filepath
+  (:export #:climacs-buffer #:needs-saving
+	   #:filepath #:file-saved-p #:file-write-time
 	   #:read-only-p #:buffer-read-only
 	   #:climacs-pane #:point #:mark
            #:clear-cache
--- /project/climacs/cvsroot/climacs/file-commands.lisp	2006/05/04 18:53:52	1.10
+++ /project/climacs/cvsroot/climacs/file-commands.lisp	2006/05/06 06:27:14	1.11
@@ -212,7 +212,7 @@
 	       (switch-to-buffer existing-buffer)
 	       (let ((buffer (make-buffer))
 		     (pane (current-window)))
-                 ;; Clear the panes cache; otherwise residue from the
+                 ;; Clear the pane's cache; otherwise residue from the
                  ;; previously displayed buffer may under certain
                  ;; circumstances be displayed.
                  (clear-cache pane)
@@ -223,6 +223,7 @@
 		 (when (probe-file filepath)
 		   (with-open-file (stream filepath :direction :input)
 		     (input-from-stream stream buffer 0))
+		   (setf (file-write-time buffer) (file-write-date filepath))
                    ;; A file! That means we may have a local options
                    ;; line to parse.
                    (evaluate-local-options-line buffer))
@@ -242,7 +243,7 @@
 
 (defun directory-of-buffer (buffer)
   "Extract the directory part of the filepath to the file in BUFFER.
-   If BUFFER does not have a filepath, the path to the users home 
+   If BUFFER does not have a filepath, the path to the user's home 
    directory will be returned."
   (make-pathname
    :directory
@@ -324,6 +325,8 @@
 
 (defun set-visited-file-name (filename buffer)
   (setf (filepath buffer) filename
+	(file-saved-p buffer) nil
+	(file-write-time buffer) nil
 	(name buffer) (filepath-filename filename)
 	(needs-saving buffer) t))
 
@@ -371,15 +374,51 @@
 	   (display-message "~A is a directory name." filepath)
 	   (beep))
 	  ((probe-file filepath)
+	   (unless (check-file-times buffer filepath "Revert" "reverted")
+	     (return-from com-revert-buffer))
 	   (erase-buffer buffer)
 	   (with-open-file (stream filepath :direction :input)
 	     (input-from-stream stream buffer 0))
-	   (setf (offset (point pane))
-		 (min (size buffer) save)))
+	   (setf (offset (point pane)) (min (size buffer) save)
+		 (file-saved-p buffer) nil))
 	  (t
 	   (display-message "No file ~A" filepath)
 	   (beep))))))
 
+(defun extract-version-number (pathname)
+  "Extracts the emacs-style version-number from a pathname."
+  (let* ((type (pathname-type pathname))
+	 (length (length type)))
+    (when (and (> length 2) (char= (char type (1- length)) #\~))
+      (let ((tilde (position #\~ type :from-end t :end (- length 2))))
+	(when tilde
+	  (parse-integer type :start (1+ tilde) :junk-allowed t))))))
+
+(defun version-number (pathname)
+  "Return the number of the highest versioned backup of PATHNAME
+or 0 if there is no versioned backup. Looks for name.type~X~,
+returns highest X."
+  (let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname))
+	 (possibilities (directory wildpath)))
+    (loop for possibility in possibilities
+	  for version = (extract-version-number possibility) 
+	  if (numberp version)
+	    maximize version into max
+	  finally (return max))))
+
+(defun check-file-times (buffer filepath question answer)
+  "Return NIL if filepath newer than buffer and user doesn't want to overwrite"
+  (let ((f-w-d (file-write-date filepath))
+	(f-w-t (file-write-time buffer)))
+    (if (and f-w-d f-w-t (> f-w-d f-w-t))
+	(if (accept 'boolean
+		    :prompt (format nil "File has changed on disk. ~a anyway?"
+				    question))
+	    t
+	    (progn (display-message "~a not ~a" filepath answer)
+		   nil))
+	t)))
+
 (defun save-buffer (buffer)
   (let ((filepath (or (filepath buffer)
 		      (accept 'pathname :prompt "Save Buffer to File"))))
@@ -388,16 +427,22 @@
        (display-message "~A is a directory." filepath)
        (beep))
       (t
-       (when (probe-file filepath)
+       (unless (check-file-times buffer filepath "Overwrite" "written")
+	 (return-from save-buffer))
+       (when  (and (probe-file filepath) (not (file-saved-p buffer)))
 	 (let ((backup-name (pathname-name filepath))
-	       (backup-type (concatenate 'string (pathname-type filepath) "~")))
+	       (backup-type (format nil "~A~~~D~~"
+				    (pathname-type filepath)
+				    (1+ (version-number filepath)))))
 	   (rename-file filepath (make-pathname :name backup-name
-						:type backup-type))))
+						:type backup-type)))
+	 (setf (file-saved-p buffer) t))
        (with-open-file (stream filepath :direction :output :if-exists :supersede)
 	 (output-to-stream stream buffer 0 (size buffer)))
        (setf (filepath buffer) filepath
+	     (file-write-time buffer) (file-write-date filepath)
 	     (name buffer) (filepath-filename filepath))
-       (display-message "Wrote: ~a" (filepath buffer))
+       (display-message "Wrote: ~a" filepath)
        (setf (needs-saving buffer) nil)))))
 
 (define-command (com-save-buffer :name t :command-table buffer-table) ()