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